I am wrting code for an excel spreadsheet to record change numbers such as 1735.01 .1735.02 for example but when it exceeds 1735.10 it outputs 1735.01 then 1735.011 where i would like 1735.10, 1735.11 up to 99,
can anyone help?
Option Explicit
Dim ws As Worksheet
Set ws = ActiveSheet
Dim newcolumn As Long
Dim i As Integer
Dim CELL As Range
newcolumn = Application.WorksheetFunction.CountA(ws.Range("A:A")) + 1
'The next two lines can be expanded as many times as needed for all the entry fields in your project
ws.Cells(newcolumn, 1).Value = Me.TextBox2.Value
ws.Cells(newcolumn, 2).Value = Me.TextBox3.Value
ws.Cells(newcolumn, 3).Value = Date
ws.Cells(newcolumn, 5).Value = Me.TextBox1.Value
ws.Cells(newcolumn, 4).Value = ws.Name & ".0" & Application.WorksheetFunction.CountA(ws.Range("D:D"))
End Sub
below is an amige of the output on the spreadsheet
[](https://i.stack.imgur.com/Ck7qZ.jpg)Private Sub CommandButton1_Click()
Related
I have the following code, and I need to make the inserted text bold. How do I add this to my statement (can't figure out the syntax)? Thanks!
Dim ws As Worksheet
Dim addme As Long
Set ws = Worksheets("Projects")
addme = ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
' Insert data from UserForm into Columns 2 & 3
With ws
ws.Cells(addme, 2).value = Me.SuperProject1.value 'the number 2 here represents the Column B
ws.Cells(addme, 3).value = Me.SProjectName1.value 'the number 3 represents Column C
End With
With ws
.Cells(addme, 2).value = Me.SuperProject1.value
.Cells(addme, 3).value = Me.SProjectName1.value
.Cells(addme, 2).Resize(1, 2).Font.Bold = True
End With
I've been writing a code that uses 3 workbooks - but I am having issues with the final output.
workbook 1 (wb1 - this workbook - where the macro is run on - and the final code will be displayed)
workbook 2 (wb2) which is a customer database for product orders
workbook 3 (wb3) which is a reference file for weights (to be manipulated in workbook 2)
wb1 opens up wb2 and wb3, cross-references (using VLOOKUP) the weights in wb3, copies them over to the corresponding customer address in wb2, then multiples the weights by the quantity ordered in wb2's address line.
The entire code works as I planned, except for the final output. wb2 now has the final weights in column Q.
All that is left is for the "PO Number" in wb1 (column K) to lookup the multiple "PO Number"s in wb2 (column C as well)
Sum wb2's weights (column Q) where there is a match
Return that sum back to wb1. I've tried sumif, but to no avail.
Here is the final output code (it returns no values at the moment), with the entire code posted below for reference.
'Enter in the weights data into the final sheet
tempCount = 0
lastCount = lastRow1
For tempCount = 1 To lastCount
Set lookFor = wb1.Sheets(1).Cells(tempCount + 1, 11) ' value to find
Set lookForRange = wb2.Sheets(1).Range("$C$2:$C$" & lastRow2) 'Range of values to lookup
Set srchRange = wb2.Sheets(1).Range("$Q$7:$Q$" & lastRow2)
wb1.Sheets(1).Activate
ActiveSheet.Cells(tempCount + 1, 12).Value = Application.WorksheetFuction.SumIf(lookForRange, lookFor, srchRange)
On Error Resume Next
Next
Below is the entire code for reference.
'Define workbooks
Dim wb2FileName As Variant
Dim wb3FileName As Variant
Dim wb1 As Workbook
Dim wb2 As Workbook
Dim wb3 As Workbook
'Count last rows in columns
Dim lastRow1 As Long
Dim lastRow2 As Long
Dim lastRow3 As Long
'Variables
Dim lookFor As Range
Dim lookForRange As Range
Dim srchRange As Range
Dim tempCount As Integer
Dim lastCount As Integer
'Open up all workbooks to work on
Set wb1 = ThisWorkbook
wb2FileName = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Customer Order Data Worksheet", MultiSelect:=False)
If wb2FileName <> False Then
Workbooks.Open Filename:=wb2FileName
End If
Set wb2 = Workbooks.Open(wb2FileName)
wb3FileName = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Source Reference File (Weights)", MultiSelect:=False)
If wb3FileName <> False Then
Workbooks.Open Filename:=wb3FileName
End If
Set wb3 = Workbooks.Open(wb3FileName)
'Find the last row in the customer data workbook and the source weights workbook
wb2.Sheets(1).Activate
lastRow2 = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
wb3.Sheets(1).Activate
lastRow3 = ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
'Use VLOOKUP to enter in weights from the reference sheet into the customer order data sheet, then multiply by the quantity
tempCount = 0
lastCount = lastRow2
For tempCount = 1 To lastCount
Set lookFor = wb2.Sheets(1).Cells(tempCount + 6, 10) ' value to find
Set srchRange = wb3.Sheets(1).Range("$B$2:$C$" & lastRow3) 'source
wb2.Sheets(1).Activate
ActiveSheet.Cells(tempCount + 6, 16).Value = Application.WorksheetFunction.VLookup(lookFor, srchRange, 2, False)
ActiveSheet.Cells(tempCount + 6, 17).Value = ActiveSheet.Cells(tempCount + 6, 11).Value * ActiveSheet.Cells(tempCount + 6, 16).Value
On Error Resume Next
Next
'Delete top 5 rows from the final sheet and insert new header
wb1.Sheets(1).Activate
ActiveSheet.Rows("1:5").Delete
ActiveSheet.Cells(1, 12).Value = "Weights"
'Find the last row on the final sheet
lastRow1 = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
'Enter in the weights data into the final sheet
tempCount = 0
lastCount = lastRow1
For tempCount = 1 To lastCount
Set lookFor = wb1.Sheets(1).Cells(tempCount + 1, 11) ' value to find
Set lookForRange = wb2.Sheets(1).Range("$C$2:$C$" & lastRow2) 'Range of values to lookup
Set srchRange = wb2.Sheets(1).Range("$Q$7:$Q$" & lastRow2)
wb1.Sheets(1).Activate
ActiveSheet.Cells(tempCount + 1, 12).Value = Application.WorksheetFuction.SumIf(lookForRange, lookFor, srchRange)
Next
Okay, I made several additions/changes to your code, so bear with me.
I added Option Explicit to the top of your module (you might already have it but you didn't include your Sub/End Sub so we couldn't tell).
Got rid of Activate & ActiveSheet. This just leads to a plethora of possible errors and a loss in readability. Use explicit references instead.
You need a way to Exit Sub if one of your wb2 or wb3 return False. If they do they'll just throw an error. Now you'll get a MsgBox and the subroutine will exit appropriately.
Got rid of On Error Resume Next. You shouldn't need that here. If you have to use it, at least turn errors back on by using On Error GoTo 0 soon after.
Moved some Sets inside their corrresponding If statements, and moved a couple static Sets outside of a loop (if it's always the same, why put it inside the loop?).
Now, for your issue with the SumIf - I believe you're encountering this issue because your criteria range and your sum range are not the same size. When they aren't, you can get a return of 0 because they don't line up properly. I've changed Range("$Q$7:$Q$" & lastRow2) to Range("$Q$2:$Q$" & lastRow2) in hopes that fixes that (but you might need to change Range("$C$2:$C$" & lastRow2) to Range("$C$7:$C$" & lastRow2) if that's your intended range.
Hope this helps!
Option Explicit
Sub Test()
'Define workbooks
Dim wb2FileName As Variant, wb3FileName As Variant
Dim wb1 As Workbook, wb2 As Workbook, wb3 As Workbook
'Count last rows in columns
Dim lastRow1 As Long, lastRow2 As Long, lastRow3 As Long
'Variables
Dim lookFor As Range, lookForRange As Range, srchRange As Range
Dim tempCount As Integer, lastCount As Integer
'Open up all workbooks to work on
Set wb1 = ThisWorkbook
wb2FileName = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Customer Order Data Worksheet", MultiSelect:=False)
If wb2FileName <> False Then
Set wb2 = Workbooks.Open(wb2FileName)
Else
MsgBox "No wb2, exiting"
Exit Sub
End If
wb3FileName = Application.GetOpenFilename(FileFilter:="Microsoft Excel Workbooks (*.csv;*.xls;*.xlsx;*.xlsm),*.csv;*.xls;*.xlsx;*.xlsm", Title:="Source Reference File (Weights)", MultiSelect:=False)
If wb3FileName <> False Then
Set wb3 = Workbooks.Open(wb3FileName)
Else
MsgBox "No wb3, exiting"
Exit Sub
End If
'Find the last row in the customer data workbook and the source weights workbook
lastRow2 = wb2.Sheets(1).Cells(Rows.Count, 3).End(xlUp).Row
lastRow3 = wb3.Sheets(1).Cells(Rows.Count, 3).End(xlUp).Row
'Use VLOOKUP to enter in weights from the reference sheet into the customer order data sheet, then multiply by the quantity
lastCount = lastRow2
For tempCount = 1 To lastCount
Set lookFor = wb2.Sheets(1).Cells(tempCount + 6, 10) ' value to find
Set srchRange = wb3.Sheets(1).Range("$B$2:$C$" & lastRow3) 'source
wb2.Sheets(1).Cells(tempCount + 6, 16).Value = Application.WorksheetFunction.VLookup(lookFor, srchRange, 2, False)
wb2.Sheets(1).Cells(tempCount + 6, 17).Value = wb2.Sheets(1).Cells(tempCount + 6, 11).Value * wb2.Sheets(1).Cells(tempCount + 6, 16).Value
Next
'Delete top 5 rows from the final sheet and insert new header
wb1.Sheets(1).Rows("1:5").Delete
wb1.Sheets(1).Cells(1, 12).Value = "Weights"
'Find the last row on the final sheet
lastRow1 = wb1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
'Enter in the weights data into the final sheet
lastCount = lastRow1
Set lookForRange = wb2.Sheets(1).Range("$C$2:$C$" & lastRow2) 'Range of values to lookup
Set srchRange = wb2.Sheets(1).Range("$Q$2:$Q$" & lastRow2)
For tempCount = 1 To lastCount
Set lookFor = wb1.Sheets(1).Cells(tempCount + 1, 11) ' value to find
wb1.Sheets(1).Cells(tempCount + 1, 12).Value = Application.WorksheetFuction.SumIf(lookForRange, lookFor, srchRange)
Next
End Sub
I have written a macro to remove rows containing certain text in it. If either of the keyword contains any text, the macro will delete the row. However, the macro doesn't work at all. Perhaps, i did something wrong in it. Hope somebody will help me rectify this. Thanks in advance.
Here is what I'm trying with:
Sub customized_row_removal()
Dim i As Long
i = 2
Do Until Cells(i, 1).Value = ""
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Cells(i, 1).Select
Selection.EntireRow.Delete
End If
i = i + 1
Loop
End Sub
The keyword within the text I was searching in to delete:
AIRLINE DRIVE OWNER mth
A rtd REPAIRS INC
AANA MICHAEL B ET AL
ABASS OLADOKUN
ABBOTT npt P
AIRLINE AANA MTH
ABASS REPAIRS NPT
Try like this.
What about Using Lcase.
Sub customized_row_removal()
Dim rngDB As Range, rngU As Range, rng As Range
Dim Ws As Worksheet
Set Ws = Sheets(1)
With Ws
Set rngDB = .Range("a2", .Range("a" & Rows.Count))
End With
For Each rng In rngDB
If InStr(LCase(rng), "mth") Or InStr(LCase(rng), "rtd") Or InStr(LCase(rng), "npt") Then
If rngU Is Nothing Then
Set rngU = rng
Else
Set rngU = Union(rngU, rng)
End If
End If
Next rng
If rngU Is Nothing Then
Else
rngU.EntireRow.Delete
End If
End Sub
VBA syntax of your Or is wrong,
If Cells(i, 1).Value = "mth" Or "rtd" Or "npt" Then
Should be:
If Cells(i, 1).Value = "mth" Or Cells(i, 1).Value = "rtd" Or Cells(i, 1).Value = "npt" Then
However, you need to use a string function, like Instr or Like to see if a certain string is found within a longer string.
Code
Option Explicit
Sub customized_row_removal()
Dim WordsArr As Variant
Dim WordsEl As Variant
Dim i As Long, LastRow As Long
Dim Sht As Worksheet
WordsArr = Array("mth", "rtd", "npt")
Set Sht = Worksheets("Sheet1")
With Sht
' get last row in column "A"
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For i = LastRow To 2 Step -1
For Each WordsEl In WordsArr
If LCase(.Cells(i, 1).Value) Like "*" & WordsEl & "*" Then
.Rows(i).Delete
End If
Next WordsEl
Next i
End With
End Sub
I try to make my code sample as I can if you have any question please ask
Private Sub remove_word_raw()
'PURPOSE: Clear out all cells that contain a specific word/phrase
Dim Rng As Range
Dim cell As Range
Dim ContainWord As String
'What range do you want to search?
Set Rng = Range("A2:A25")
'sub for the word
shorttext1 = "mth"
shorttext2 = "rtd"
shorttext3 = "npt"
'What phrase do you want to test for?
ContainWord1 = shorttext1
ContainWord2 = shorttext2
ContainWord3 = shorttext3
'Loop through each cell in range and test cell contents
For Each cell In Rng.Cells
If cell.Value2 = ContainWord1 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord2 Then cell.EntireRow.Delete
Next
For Each cell In Rng.Cells
If cell.Value2 = ContainWord3 Then cell.EntireRow.Delete
Next cell
End Sub
The point of this code is to take user inputs from a "Remove Flags" tab in which the user puts an item number and what program it belongs to, filters the "Master List" tab by the item number and the program, then match the name of the flag to the column and delete the flag. However the offset is not working. It is instead deleting the header. When I step through it everything works fine until the line I marked with '*******.
I am fairly new to VBA and am self taught so any and all help is greatly appreciated. Thank you very much for your time.
EDIT: Removed "On Error Resume Next" and fixed some spelling errors. Current issue is with rng not having >1 rows when it is filtered and definitely has two rows (one row is the header, one row is the returned data.)
Sub RemoveFlag()
Dim cel As Range
Dim rg As Range
Dim d As Double
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim rng As Range
Dim wsMaster As Worksheet
Dim wsFlag As Worksheet
Set wsMaster = Worksheets("Master List")
Set wsFlag = Worksheets("Remove Flags")
i = 6
'If there is no data. Do nothing.
If wsFlag.Range("C6") = "" Then
wsFlag.Activate
Else
Application.ScreenUpdating = False
'Add Leading zeroes
wsFlag.Activate
Set rg = Range("C6")
Set rg = Range(rg, rg.Worksheet.Cells(Rows.Count, rg.Column).End(xlUp))
rg.NumberFormat = "#"
For Each cel In rg.Cells
If IsNumeric(cel.Value) Then
d = Val(cel.Value)
cel.Value = Format(d, "000000000000000000") 'Eighteen digit number
End If
Next
'Clear all the filters on the Master List tab.
wsMaster.Activate
If wsMaster.AutoFilterMode = True Then
wsMaster.AutoFilterMode = False
End If
'Loop through all lines of data
Do While wsFlag.Cells(i, 3).Value <> ""
'Filter by the SKU number
wsMaster.Range("A1").AutoFilter Field:=4, Criteria1:=wsFlag.Cells(i, 3).Value
'Filter by the Program
wsMaster.Range("A1").AutoFilter Field:=2, Criteria1:=wsFlag.Cells(i, 2).Value
'If the filter is not empty find the column of the flag
Set rng = wsMaster.UsedRange.SpecialCells(xlCellTypeVisible)
If (rng.Rows.Count > 1) Then
wsMaster.Range("A1:Z1").Find(wsFlag.Cells(i, 4), LookIn:=xlValues).Activate
n = ActiveCell.Column
Sheets("Master List").Range.Offset(1, 0).SpecialCells(xlCellTypeVisible).Select
m = ActiveCell.Row
Cells(m, n) = ""
wsFlag.Activate
wsFlag.Range(Cells(i, 2), Cells(i, 4)).ClearContents
Else
wsFlag.Activate
wsFlag.Range(Cells(i, 2), Cells(i, 4)).Copy
wsFlag.Range("F4").End(xlDown).Offset(1, 0).Activate
ActiveCell.PasteSpecial Paste:=xlPasteValues
wsFlag.Range(Cells(i, 2), Cells(i, 4)).ClearContents
End If
wsMaster.Activate
wsMaster.AutoFilterMode = False
i = i + 1
Loop
'Make sure the entire Master List tab is not highlighted and pull the 'highlighted cell' to A1 in both tabs.
wsMaster.Activate
wsMaster.Range("A1").Activate
wsFlag.Activate
Range("A1").Activate
'Unfreeze the screen
Application.ScreenUpdating = True
End If
End Sub
As #Zerk suggested, first set two Worksheet variables at top of code:
Dim wsMaster As Worksheet
Dim wsRemoveFlags As Worksheet
Set wsMaster = Worksheets("Master List")
Set wsRemoveFlags = Worksheets("Remove Flags")
Then replace all other instances of Worksheets("Master List") with wsMaster and Worksheets("Remove Flags") with wsRemoveFlags.
Sometimes it's easier to just loop through your rows and columns. Something like the following:
Replace everything between:
Do While wsFlag.Cells(i, 3).Value <> ""
...
Loop
with:
Do While wsFlag.Cells(i, 3).Value <> ""
Dim r As Long ' Rows
Dim c As Long ' Columns
Dim lastRow As Long
Dim found As Boolean
lastRow = wsMaster.Cells.SpecialCells(xlLastCell).Row
found = False
For r = 2 To lastRow ' Skipping Header Row
' Find Matching Program/SKU
If wsMaster.Cells(r, 2).Value = wsFlag.Cells(i, 2).Value _
And wsMaster.Cells(r, 3) = wsFlag.Cells(i, 3).Value Then
' Find Flag in Row
For c = 1 To 26 ' Columns A to Z
If wsMaster.Cells(r, c) = wsFlag.Cells(i, 4) Then
' Found Flag
wsMaster.Cells(r, c) = ""
found = True
Exit For ' if flag can be in more than one column, remove this.
End If
Next 'c
End If
Next 'r
If Not found Then
' Here is where you need to put code if Flag wsFlag.Cells(i, 4) not found.
End If
Loop
My model takes two numbers from one sheet, adds the average to another sheet in the last cell of a defined column. The problem that I have is that when I insert a new column, the references get missed up and I'm trying to have a macro that would 1. take the average 2. look for a specific column on the second sheet 3. paste the averaged value to the last cell.
Please help me with this I have been trying to get my head around it for a long time.
Thank you.
This is my code: what it basically does now is find the last emptyrow and I have to put in a number for a column to reference a cell. What I want is to have the column reference dynamic so when I insert a new column i dont have to change the macro.
Private Sub CommandButton1_Click()
Dim emptyRow As Long, Answer As Double, result As String
Application.ScreenUpdating = False
Sheet1.Activate
RowCount = Worksheets("Sheet1").Range("A1").CurrentRegion.Rows.Count
With Sheets("Sheet1").Range("A1")
.Offset(1, 2).Value = Me.TextBox1.Value
.Offset(1, 3).Value = Me.TextBox2.Value
.Offset(2, 2).Value = Me.TextBox3.Value
.Offset(2, 3).Value = Me.TextBox4.Value
.Offset(3, 2).Value = Me.TextBox5.Value
.Offset(3, 3).Value = Me.TextBox6.Value
.Offset(4, 2).Value = Me.TextBox7.Value
.Offset(4, 3).Value = Me.TextBox8.Value
End With
Sheet2.Activate
emptyRow = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
Answer = Application.WorksheetFunction.Average(Range("C2:D2"))
Sheets("Sheet2").Cells(emptyRow, 1).Value = Answer
Answer = Application.WorksheetFunction.Average(Range("C3:D3"))
Sheets("Sheet2").Cells(emptyRow, 2).Value = Answer
Answer = Application.WorksheetFunction.Average(Range("C4:D4"))
Sheets("Sheet2").Cells(emptyRow, 3).Value = Answer
Answer = Application.WorksheetFunction.Average(Range("C5:D5"))
Sheets("Sheet2").Cells(emptyRow, 4).Value = Answer
End Sub
One way is to assign a Name to the column:
Sub demo()
Range("B:B").Cells.Name = "expenses"
End Sub
If columns are inserted at the beginning of the worksheet, the named range will adjust.
EDIT#1:
After the Name has been assigned, here is an example of filling the first empty cell (at the bottom of the column) of the expense column with the value 123
Sub TheNextStep()
Dim expCol As Long, FirstEmptyRow As Long
expCol = Range("expenses").Column
FirstEmptyRow = Cells(Rows.Count, expCol).End(xlUp).Row + 1
Cells(FirstEmptyRow, expCol).Value = 123
End Sub