VBA button - based on a cell value rather than ActiveCell - excel

I am very new to VBA and trying to update the code below to look for a value within a cell rather than ActiveCell. Specifically, I want to find the row below a cell with a value of "B." (e.g.), copy the 3 rows below, and paste+insert those 3 rows directly beneath the copied 3 rows. Effectively, I am trying to get my VBA button to work without asking users to first click into a specific cell. My current code, based on ActiveCell, is working well as long as you are in the correct cell. Any insight would be helpful.
Sub CommandButton2_Click()
Dim NextRow As Long
Dim I As Long
With Range(ActiveCell.Offset(rowOffset:=2), ActiveCell.Offset(rowOffset:=0))
NextRow = .Row + .Rows.Count
Rows(NextRow & ":" & NextRow + .Rows.Count * (1) - 1).Insert Shift:=xlDown
.EntireRow.Copy Rows(NextRow & ":" & NextRow + .Rows.Count * (1) - 1)
.Resize(.Rows.Count * (1 + 1)).Sort key1:=.Cells(1, 1)
End With
End Sub

Please, test the next updated code. It will require the string/text of the cell you need to identify (in an InputBox). For testing reason, I used the string "testSearch". Please, put it in the cell of A:A to be identified and test it. Then, you can use whatever string you need...
Sub testTFindCellFromString()
Dim NextRow As Long, I As Long, strSearch As String
Dim sh As Worksheet, actCell As Range, rng As Range
strSearch = InputBox("Please, write the string from the cell to be identified", _
"Searching string", "testSearch")
If strSearch = "" Then Exit Sub
Set sh = ActiveSheet
Set rng = sh.Range("A1:A" & sh.Range("A" & Cells.Rows.Count).End(xlUp).Row)
Set actCell = testFindActivate("testSearch", rng)
If actCell Is Nothing Then Exit Sub
With Range(actCell.Offset(2, 0), actCell.Offset(0, 0))
NextRow = .Row + .Rows.Count
Rows(NextRow & ":" & NextRow + .Rows.Count * (1) - 1).Insert Shift:=xlDown
.EntireRow.Copy Rows(NextRow & ":" & NextRow + .Rows.Count * (1) - 1)
.Resize(.Rows.Count * (1 + 1)).Sort key1:=.Cells(1, 1)
End With
Debug.Print actCell.Address
End Sub
Private Function testFindActivate(strSearch As String, rng As Range) As Range
Dim actCell As Range
Set actCell = rng.Find(What:=strSearch)
If actCell Is Nothing Then
MsgBox """" & strSearch & """ could not be found..."
Exit Function
End If
Set testFindActivate = actCell
End Function

Related

How to make VBA code faster/more efficient

So I have designed this code to insert new entries into my master Database Log but when I run the code it is much too slow.
Private Sub CommandButton2_Click()
Dim ws As Worksheet
Dim LR As Long, i As Long, iRow As Long
Set ws = ThisWorkbook.Worksheets("Data Entry")
With ws
LR = .Cells(Rows.Count, 1).End(xlUp).Row
If 2 > LR Then Exit Sub
iRow = 3
For i = 1 To LR
If .Cells(i, 1).DisplayFormat.Interior.Color = RGB(217, 230, 251) Then
Worksheets("Call Log").Rows("3:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Cells(i, 1).Resize(1, 7).Copy ThisWorkbook.Worksheets("Call Log").Cells(iRow, "A")
End If
Next i
End With
Set ws = Nothing
End Sub
As you can see, my code goes through the range, determines if it matches my criteria (in this case the color of the cell) and then Inserts a row in the destination Worksheet and copies the data into that newly created row over and over until it finishes. I've thought of maybe having it select all of the necessary cells, copy and then insert them all at once into the destination worksheet, but I'm not sure how to go about that.
Any help is greatly appreciated!
One of the things you are doing obsoletely, is copying something to the clipboard, while this is not necessary: instead of
Range("<somewhere>").Copy
Range("<elsewhere>").Paste
You might simply do:
Range("<elsewhere>".Value = Range("<somewhere>").Value
It's always a good idea to turn off screen updating and set calculations to manual (unless you need it)
Application.SceenUpdating = false
Application.calculations = xlmanual
Then set them back to true and xlautomatic at the end of the code.
Not sure if the syntaxes is correct, I'm typing from my phone
If you absolutely need to copy the source formatting of the cells also, then you could use a filter and then copy only the visible cells, all in one go. Something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
Dim filterColor As Long
'
'Filter Range
filterColor = RGB(217, 230, 251)
With Range(shtData.Cells(1, 1), shtData.Cells(lastRow, 1))
.AutoFilter Field:=1, Criteria1:=filterColor, Operator:=xlFilterCellColor
End With
'
Dim rng As Range
Const lastCol As Long = 7
Dim firstRow As Long
'
'Get filtered range
'First row remains visible regardless of filter. Check it
If shtData.Cells(1, 1).Cells(1, 1).DisplayFormat.Interior.Color <> filterColor Then
firstRow = 2
Else
firstRow = 1
End If
On Error Resume Next
Set rng = Range(shtData.Cells(firstRow, 1), shtData.Cells(lastRow, lastCol)).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then Exit Sub 'Nothing meets criteria
'
Dim tempArea As Range
Dim rCount As Long
'
'Get required rows count
For Each tempArea In rng.Areas
rCount = rCount + tempArea.Rows.Count
Next tempArea
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + rCount - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
rng.Copy shtLog.Cells(iRow, 1)
'
'Remove filter
rng.AutoFilter
End Sub
But, if you don't care about source formatting then you could use something like this:
Private Sub CommandButton2_Click()
Const shtDataName As String = "Data Entry"
Const shtLogName As String = "Call Log"
Dim shtData As Worksheet
Dim shtLog As Worksheet
'
'Make sure required resources are available
Set shtData = GetWorksheet(shtDataName, ThisWorkbook)
If shtData Is Nothing Then
MsgBox "Missing sheet <" & shtDataName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
Set shtLog = GetWorksheet(shtLogName, ThisWorkbook)
If shtLog Is Nothing Then
MsgBox "Missing sheet <" & shtLogName & ">!", vbInformation, "Cancelled"
Exit Sub
End If
'
'Check last row
Dim lastRow As Long
'
lastRow = shtData.Cells(Rows.Count, 1).End(xlUp).Row
If lastRow = 1 Then Exit Sub
'
'Read data in array (super fast)
Dim rng As Range
Dim arrData() As Variant
Const lastCol As Long = 7
'
Set rng = Range(shtData.Cells(1, 1), shtData.Cells(lastRow, lastCol))
arrData = rng.Value2
'
'Store relevant row numbers
Dim collRows As New Collection
Dim i As Long
Dim filterColor As Long: filterColor = RGB(217, 230, 251)
'
For i = LBound(arrData) To UBound(arrData)
If rng.Cells(i, 1).DisplayFormat.Interior.Color = filterColor Then
collRows.Add i
End If
'
'I am not a fan of using colors for filtering. It's much faster to have a separate
' column (indicator column) that can be used for that. This way we could do
' something like: If arrData(i, indCol) = expectedValue Then ...
' which is much faster than accesing cells
Next i
'
'Prepare data for writing
Dim arrFiltered() As Variant
ReDim arrFiltered(1 To collRows.Count, 1 To lastCol)
Dim r As Variant
Dim c As Long
'
i = 0
For Each r In collRows
i = i + 1
For c = 1 To lastCol
arrFiltered(i, c) = arrData(r, c)
Next c
Next r
'
'Insert rows
Const iRow As Long = 3
'
shtLog.Rows(iRow & ":" & iRow + collRows.Count - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'
'Write
With Range(shtLog.Cells(iRow, 1), shtLog.Cells(iRow + collRows.Count - 1, lastCol))
.Value2 = arrFiltered
End With
End Sub
Private Function GetWorksheet(ByVal sheetName As String, ByVal book As Workbook) As Worksheet
On Error Resume Next
Set GetWorksheet = book.Worksheets(sheetName)
On Error GoTo 0
End Function
The above is rushed code but proves some ways of doing the task. Other things that need to be considered are:
Are the worksheets protected? if yes, filtering and inserting rows can be an issue
Inserting rows will fail if the rows are intersecting multiple dynamic tables (listobjects)
Code needs to be changed if data doesn't start on row 1 in the source
and probably others that don't come to mind right now

How to loop through a list and print the outputs

I'm really new to Excel VBA but recently need to come up with a solution to have excel iterate through a list and print the output.
Here on tab "Sheet2" is the item master. Each of the items is designated an Item Code.
On "Sheet1" I have a formula that finds the Unit Price and Starting Level and calculates the Total On Hand Liabilities.
I'd like to have Excel populate in cell Sheet1!A2 with each of the values in range Sheet2!A1:A, do the calculations, and paste all each of the outputs in a new sheet, as shown below.
Thank you.
I made a basic macro to do this, maybe you could tweak it to suit your needs.
Option Explicit
Sub Test()
Dim rng As Range
Dim switch As Boolean
switch = False
For Each rng In Worksheets("Sheet2").Range("A2", Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp))
Worksheets("Sheet1").Select
Range("A" & Rows.Count).End(xlUp).Select
'so that for the first iteration it will not offset, assuming you start off with blank wksht
If switch = True Then
ActiveCell.Offset(2, 0).Select
End If
ActiveCell.Value = "Item Number"
ActiveCell.Offset(0, 1).Value = "Description"
ActiveCell.Offset(0, 2).Value = "On Hand Liability"
ActiveCell.Offset(1, 0).Value = rng.Value
ActiveCell.Offset(1, 1).Value = rng.Offset(0, 1).Value
ActiveCell.Offset(1, 2).Value = rng.Offset(0, 2) * rng.Offset(0, 3)
switch = True
Next rng
End Sub
Suggest you use the Microsoft VBA language reference to look up loops. E.g. https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/for-eachnext-statement
Here is an example which will produce your output:
Option Explicit
Public Sub PopulateSheet1()
Dim SourceSheet As Worksheet
Dim SourceRow As Range
Dim SourceRows As Long
Dim TargetSheet As Worksheet
Dim TargetRow As Long
Set SourceSheet = ActiveWorkbook.Sheets("Sheet2")
Set TargetSheet = ActiveWorkbook.Sheets("Sheet1")
SourceRows = SourceSheet.Cells(Rows.Count, 1).End(xlUp).Row
TargetRow = 1
For Each SourceRow In SourceSheet.Range("A2:A" & SourceRows)
TargetSheet.Cells(TargetRow, 1) = Array("Item Number", "Description", "On Hand Liability")
TargetRow = TargetRow + 1
SourceRow.Cells(1, 1).Copy TargetSheet.Cells(TargetRow, 1)
TargetSheet.Cells(TargetRow, 2) = "=VLOOKUP(Sheet1!A" & TargetRow & ",Sheet2!A:B,2,FALSE)"
TargetSheet.Cells(TargetRow, 3) = "=VLOOKUP(Sheet1!A" & TargetRow & ",Sheet2!A:D,3,FALSE) * VLOOKUP(Sheet1!A" & TargetRow & ",Sheet2!A:D,4,FALSE)"
TargetSheet.Cells(TargetRow, 3).NumberFormat = "$#,##0.00"
TargetRow = TargetRow + 2
Next
End Sub

Copying the Cells Below A Text

I am trying to copy 3 entire rows below a cell which includes a text.
I've already wrote this but there are some issues that I can't solve due to being a beginner of VBA.
Option Explicit
Private Sub SearchandInsertRows()
Dim lRow As Long, iRow As Long
With Worksheets("Main_Page")
lRow = .Cells(.Rows.Count, "A").End(xlup).Row
For iRow = lRow to 1 Step -1
If .Cells(iRow, "A").Value = Range("D5") Then
.Rows(iRow).Resize(3).Insert
End if
Next iRow
End With
End Sub
I want excel to read the entire A column and find the cell which has same text with cell D5 (Text is BillNumber). Then add 3 blank rows above that. Lastly copy the three cells below BillNumber and paste it to recently created 3 blank rows.
Here is screenshot to make it more understandable.
Here is one way, remove the MsgBox lines, they are for debugging.
Sub insertPaste()
Dim D5Val As String, wk As Workbook, fVal As Range
Set wk = ThisWorkbook
With wk.Sheets("Sheet1")
'Value from D5
D5Val = .Range("D5").Value
'Find D5 on column A
Set fVal = .Columns("A:A").Find(D5Val, , xlValues, , xlNext)
If fVal Is Nothing Then
'Not found
MsgBox "Not Found"
Else
'Found
MsgBox "Found at: " & fVal.Address
'Insert 3 Cells on top of the cell found with the data from the 3 cells below
.Range("A" & (fVal.Row + 1) & ":A" & (fVal.Row + 3)).Copy
.Range("A" & fVal.Row & ":A" & (fVal.Row + 2)).Insert Shift:=xlDown
Application.CutCopyMode = False
End If
End With
End Sub
Copy Cells Below Text Above Text
The Code
Private Sub SearchandInsertRows()
Dim lRow As Long, iRow As Long
With Worksheets("Main_Page")
lRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For iRow = lRow To 1 Step -1
If .Cells(iRow, "A").Value = .Range("D6") Then
.Rows(iRow).Resize(3).Insert
.Rows(iRow + 3 & ":" & iRow + 5).Copy .Rows(iRow)
End If
Next iRow
End With
End Sub

VBA Collection issue

I an trying towrite a simple VBA code where some cell values are combined.
Problem with code bellow is that Cell Object in the loop keeps selecting whole row, not just one cell in Row Collection
Dim Cell As Range
Dim Row As Range
Set Row = Rows(ActiveCell.Row)
Set Cell = ActiveCell
For Each Cell In Row
With Cell
If IsNumeric(InStr(1, Right(.Value, 1), "/")) Then
.Value = .Value & .Offset(0, 1).Value
.Offset(0, 1).Delete (xlShiftToLeft)
End If
End With
Next Cell
Try this. For this example, assumptions made about data being on Sheet1 and the start row (stRow) and start col (testCol) of the data. Amend these to suit your conditions.
Option Explicit
Sub combine()
Dim ws As Worksheet
Dim stRow As Long, endRow As Long, testCol As Long, endCol As Long
Dim rnum As Long, cnum As Long
Dim cl As Range
Set ws = Sheets("Sheet1")
stRow = 1
testCol = 1
With ws
endRow = .Cells(Rows.Count, testCol).End(xlUp).Row
For rnum = stRow To endRow
endCol = .Cells(rnum, Columns.Count).End(xlToLeft).Column
For cnum = testCol To endCol - 1
Set cl = .Cells(rnum, cnum)
If Right(cl, 1) = "/" And Right(cl.Offset(0, 1), 1) <> "/" Then
If IsNumeric(Left(cl.Value, Len(cl.Value) - 1)) Then
cl.Value = cl.Value & cl.Offset(0, 1).Value
cl.Offset(0, 1).Delete (xlShiftToLeft)
End If
End If
Next cnum
Next rnum
End With
End Sub
Although not specified by you, this code does not combine an adjacent cell which also has a trailing "/". This on the basis that we shouldn't 'remove' a 'test' value. If this condition not required it is easily changed.

Excel 2010 VBA. Concatenate 2 columns from a Sheet and paste them in another

Using Excel 2010, I'm trying to create a script that concatenates two text columns (A and B) from Sheet1 and pastes the result in column A of Sheet2.
The workbook uses an external datasource for loading both columns, so the number of rows is not fixed.
I've tried the following code, but not working. variable lRow is not taking any value.
Sub Concat()
Sheets("Sheet1").Select
Dim lRow As Long
lRow = Range("A" & Rows.count).End(xlUp).Row
For i = 2 To lRow
ActiveWorkbook.Sheets("Sheet2").Cells(i, 1) = Cells(i, 1) & Cells(i, 2)
Next i
End Sub
What am I doing wrong. Thanks for helping!
As to what are you doing wrong, I suggest you use
Sub Concat()
Sheets("Sheet1").Select
Dim lRow As Long, i As Long
Dim rng As Range
Set rng = Range("A" & Rows.Count).End(xlUp)
Debug.Print rng.Address(External:=True)
lRow = rng.Row
For i = 2 To lRow
ActiveWorkbook.Sheets("Sheet2").Cells(i, 1) = Cells(i, 1) & Cells(i, 2)
Next i
End Sub
to see what is going on. I tried exactly what you used and it worked for me (Excel 2010).
Specifying what does "variable lRow is not taking any value" mean would help.
You could also try alternatively
Sub Concat2()
Sheets("Sheet1").Select
Dim lRow As Long, i As Long
Dim rng As Range
Set rng = Range("A2").End(xlDown)
Debug.Print rng.Address(External:=True)
lRow = rng.Row
For i = 2 To lRow
ActiveWorkbook.Sheets("Sheet2").Cells(i, 1) = Cells(i, 1) & Cells(i, 2)
Next i
End Sub
which should give the same result if yo do not have blank cells in the middle of the source column A.
I would advise getting out of the .Select method of XL VBA programming in favor of direct addressing that will not leave you hanging with errors.
Sub Concat()
Dim i As Long, lRow As Long
With Sheets("Sheet1")
lRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
Sheets("Sheet2").Cells(i, 1) = .Cells(i, 1) & .Cells(i, 2)
Next i
End With
End Sub
Note the periods (aka . or full stop) that prefix .Cells and .Range. These tell .Cells and .Range that they belong to the worksheet referenced in the With ... End With block; in this example that would be Sheets("Sheet1").
If you have a lot of rows to string together you would be better off creating an array of the values from Sheet1 and processing the concatenation in memory. Split off the concatenated values and return them to Sheet2.
Sub concat2()
Dim c As Long, rws As Long, vCOLab As Variant
With Sheets("Sheet1")
rws = .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row).Rows.Count
vCOLab = .Range("A2").Resize(rws, 3)
For c = LBound(vCOLab, 1) To UBound(vCOLab, 1)
'Debug.Print vCOLab(c, 1) & vCOLab(c, 2)
vCOLab(c, 3) = vCOLab(c, 1) & vCOLab(c, 2)
Next c
End With
Sheets("Sheet2").Range("A2").Resize(rws, 1) = Application.Index(vCOLab, , 3)
End Sub
When interacting with a worksheet, bulk operations will beat a loop every time; the only question is by how much.

Resources