Match cell value to a combobox row value - vba

Question

I'm trying to figure out a different method of running a piece of code.
Basically what my code is doing at the moment is, looping though column Q in the Global sheet, then looping though Combobox2, when it finds a match the entire rows get moved to the sheet reference in column 1 of the combobox.
Is it possible to use the Match function to achieve the same results and speed up the code??
This is currently the code I'm using, it does what I need it to do, but I cannot get error handling working for it. And it there are many rows of data to loop through it can take a long time!
Option 1:
Private Sub CommandButton6_Click()
Dim i As Long, j As Long, lastG As Long, strWS As String, rngCPY As Range
Dim StartTime As Double
Dim SecondsElapsed As Double
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
End With
StartTime = Timer
If Range("L9") = "" Then
MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation"
Exit Sub
End If
If sheets("Global").Range("A3") = "" Then
MsgBox "The appears to be no application loaded." & vbLf & vbLf & "Please load" & " " & Range("C11") & " " & "App and Planet Info, then click button 2 and try again.", vbExclamation, "Invalid Operation"
Exit Sub
End If
On Error GoTo bm_Close_Out
' find last row
lastG = sheets("Global").Cells(Rows.Count, "Q").End(xlUp).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
If sheets("PAYMENT FORM").Range("L40") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
If lookupVal = currval Then
Set rngCPY = sheets("Global").Cells(i, "Q").EntireRow
strWS = Me.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet '<~~ if the worksheet in the next line does not exist, go make one
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
End If
Next i
Next j
End If
Else
If sheets("PAYMENT FORM").Range("L35") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
For i = 3 To lastG
lookupVal = sheets("Global").Cells(i, "Q") ' value to find
If lookupVal = currval Then
Set rngCPY = sheets("Global").Cells(i, "Q").EntireRow
strWS = Me.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet '<~~ if the worksheet in the next line does not exist, go make one
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
End If
Next i
Next j
End If
End If
GoTo bm_Close_Out
bm_Need_Worksheet:
On Error GoTo 0
With Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTemplate As Worksheet: Set wsTemplate = wb.sheets("Template")
Dim wsPayment As Worksheet: Set wsPayment = wb.sheets("Payment Form")
Dim wsNew As Worksheet
Dim lastRow2 As Long
Dim Contract As String: Contract = sheets("Payment Form").Range("C9").value
Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
Dim Name As String: Name = Left(Contract, SpacePos)
Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))
Dim NewName As String: NewName = strWS
Dim CCName As Variant: CCName = Me.ComboBox2.List(j, 2)
Dim LastRow As Long: LastRow = wsPayment.Range("U36:U53").End(xlDown).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
lastRow2 = wsPayment.Range("A23:A39").End(xlDown).row
Else
lastRow2 = wsPayment.Range("A18:A34").End(xlDown).row
End If
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsPayment
For Each cell In .Range("A23:A39")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
Else
With wsPayment
For Each cell In .Range("A18:A34")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
End If
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A23:A39").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
Else
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A18:A34").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
End If
wsPayment.Activate
With wsPayment
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
.Range("U" & LastRow + 1).value = NewName & ": "
.Range("V" & LastRow + 1).Formula = "='" & NewName & "'!I21"
.Range("W" & LastRow + 1).Formula = "='" & NewName & "'!I23"
.Range("X" & LastRow + 1).Formula = "='" & NewName & "'!K21"
End With
End With
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
End With
End Sub
Option 2:
Private Sub CommandButton1_Click()
Dim j As Long, strWS As String, rngCPY As Range, FirstAddress As String, sSheetsWithData As String
Dim sSheetsWithoutData As String, lSheetRowsCopied As Long, lAllRowsCopied As Long, bFound As Boolean, sOutput As String
Dim StartTime As Double
Dim SecondsElapsed As Double
With Application
.ScreenUpdating = False
.EnableEvents = False
.CutCopyMode = False
.EnableEvents = False
End With
StartTime = Timer
On Error GoTo bm_Close_Out
For j = 0 To UserForm2.ComboBox2.ListCount - 1
bFound = False
currval = UserForm2.ComboBox2.List(j, 0) ' value to match
With sheets("Global")
Set rngCPY = sheets("Global").Range("Q:Q").Find(currval, LookIn:=xlValues)
If Not rngCPY Is Nothing Then
bFound = True
lSheetRowsCopied = 0
FirstAddress = rngCPY.Address
Do
lSheetRowsCopied = lSheetRowsCopied + 1
strWS = UserForm2.ComboBox2.List(j, 1)
On Error GoTo bm_Need_Worksheet
With Worksheets(strWS)
rngCPY.EntireRow.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
Set rngCPY = sheets("Global").Range("Q:Q").FindNext(rngCPY)
Loop Until rngCPY Is Nothing Or rngCPY.Address = FirstAddress
Else
bFound = False
End If
If bFound Then
sSheetsWithData = sSheetsWithData & " " & strWS & " (" & lSheetRowsCopied & ")" & vbLf
lAllRowsCopied = lAllRowsCopied + lSheetRowsCopied
End If
End With
Next j
bm_Need_Worksheet:
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTemplate As Worksheet: Set wsTemplate = wb.sheets("Template")
Dim wsPayment As Worksheet: Set wsPayment = wb.sheets("Payment Form")
Dim wsNew As Worksheet
Dim lastRow2 As Long
Dim Contract As String: Contract = sheets("Payment Form").Range("C9").value
Dim SpacePos As Integer: SpacePos = InStr(Contract, "- ")
Dim Name As String: Name = Left(Contract, SpacePos)
Dim Name2 As String: Name2 = Right(Contract, Len(Contract) - Len(Name))
Dim NewName As String: NewName = strWS
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim LastRow As Long: LastRow = wsPayment.Range("U36:U53").End(xlDown).row
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
lastRow2 = wsPayment.Range("A23:A39").End(xlDown).row
Else
lastRow2 = wsPayment.Range("A18:A34").End(xlDown).row
End If
wsTemplate.Visible = True
wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
wsTemplate.Visible = False
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsPayment
For Each cell In .Range("A23:A39")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
Else
With wsPayment
For Each cell In .Range("A18:A34")
If Len(cell) = 0 Then
If sheets("Payment Form").Range("C9").value = "Network" Then
cell.value = NewName & " - " & Name2 & ": " & CCName
Else
cell.value = NewName & " -" & Name2 & ": " & CCName
End If
Exit For
End If
Next cell
End With
End If
If InStr(1, sheets("Payment Form").Range("A20").value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A23:A39").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
Else
With wsNew
.Name = NewName
.Range("D4").value = wsPayment.Range("A18:A34").End(xlDown).value
.Range("D6").value = wsPayment.Range("L11").value
.Range("D8").value = wsPayment.Range("C9").value
.Range("D10").value = wsPayment.Range("C11").value
End With
End If
wsPayment.Activate
With wsPayment
.Range("J" & lastRow2 + 1).value = 0
.Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
.Range("N" & lastRow2 + 1).Formula = "='" & NewName & "'!L20"
.Range("U" & LastRow + 1).value = NewName & ": "
.Range("V" & LastRow + 1).Formula = "='" & NewName & "'!I21"
.Range("W" & LastRow + 1).Formula = "='" & NewName & "'!I23"
.Range("X" & LastRow + 1).Formula = "='" & NewName & "'!K21"
End With
On Error GoTo bm_Close_Out
Resume
bm_Close_Out:
If sSheetsWithData <> vbNullString Then
sOutput = "# of rows copied to sheets:" & vbLf & vbLf & sSheetsWithData & vbLf & _
"Total rows copied = " & lAllRowsCopied & vbLf & vbLf
Else
sOutput = "No sheets contained data to be copied" & vbLf & vbLf
End If
If sSheetsWithoutData <> vbNullString Then
sOutput = sOutput & "Sheets with no rows copied:" & vbLf & vbLf & sSheetsWithoutData
Else
sOutput = sOutput & "All sheets had data that was copied."
End If
If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"
Set rngCPY = Nothing
SecondsElapsed = Round(Timer - StartTime, 2)
MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation
With Application
.ScreenUpdating = True
.EnableEvents = True
.CutCopyMode = True
.EnableEvents = True
End With
End Sub

Answer 1

OK... It's more like a try than an answer. pls check if that is working and if it is faster.
Use this macro only with a copy of your workbook!
Private Sub CommandButton2_Click()
Dim i As Long, j As Long, k As Long, strWS As String, rngCPY As Range
Dim noFind As Variant: noFind = UserForm2.ComboBox2.List '<~~~ get missed items
With Application: .ScreenUpdating = False: .EnableEvents = False: .CutCopyMode = False: End With
If Range("L9") = "" Then: MsgBox "You can't Split the Jobs at this stage. " & vbLf & vbLf & "Please create the form for the Sub-Contractor First." & vbLf & vbLf & "Please press Display Utilities to create form.", vbExclamation, "Invalid Operation": Exit Sub
Dim lastG As Long: lastG = Sheets("Global").Cells(Rows.Count, 17).End(xlUp).row
Dim cVat As Boolean: cVat = InStr(1, Sheets("Payment Form").Range("A20").Value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE")
If Sheets("PAYMENT FORM").Cells(35 - cVat * 5, 12) >= 1 Then: MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation": Exit Sub
'~~~ acivate next line to sort (will speed up a lot)
'Sheets("Global").Range("A3:R" & Cells(Rows.Count, 17).End(xlUp).row).Sort cells(3,17), 1
For j = 0 To UserForm2.ComboBox2.ListCount - 1
noFind(j, 4) = 0
For i = 3 To lastG
If noFind(j, 0) = Sheets("Global").Cells(i, 17) Then
k = i
strWS = UserForm2.ComboBox2.List(j, 1)
On Error Resume Next
If Len(Worksheets(strWS).Name) = 0 Then
With ThisWorkbook
On Error GoTo 0
Dim nStr As String: With Sheets("Payment Form").Range("C9"): nStr = Right(.Value, Len(.Value) - Len(Left(.Value, InStr(.Value, "- ")))): End With
Dim CCName As Variant: CCName = UserForm2.ComboBox2.List(j, 2)
Dim lastRow As Long: lastRow = Sheets("Payment Form").Range("U36:U53").End(xlDown).row + 1
Dim strRng As String: strRng = Array("A18:A34", "A23:A39")(-1 * cVat)
Dim lastRow2 As Long: lastRow2 = Sheets("Payment Form").Range(strRng).End(xlDown).row + 1
Dim wsNew As Worksheet: .Sheets("Template").Copy .Sheets(.Sheets.Count): Set wsNew = .Sheets(.Sheets.Count): wsNew.Move .Sheets("Details")
With Sheets("Payment Form")
For Each cell In .Range(strRng)
If Len(cell) = 0 Then
If Sheets("Payment Form").Range("C9").Value = "Network" Then
cell.Offset.Value = strWS & " - " & nStr & ": " & CCName
Else
cell.Offset.Value = strWS & " -" & nStr & ": " & CCName
End If
Exit For
End If
Next cell
End With
With wsNew
.Visible = -1
.Name = strWS
.Cells(4, 4).Value = Sheets("Payment Form").Range(strRng).End(xlDown).Value
.Cells(6, 4).Value = Sheets("Payment Form").Cells(12, 12).Value
.Cells(8, 4).Value = Sheets("Payment Form").Cells(9, 3).Value
.Cells(10, 4).Value = Sheets("Payment Form").Cells(11, 3).Value
End With
With .Sheets("Payment Form")
.Activate
.Cells(lastRow2, 10).Value = 0
.Cells(lastRow2, 12).Formula = "=N" & lastRow2 & "-J" & lastRow2 & ""
.Cells(lastRow2, 14).Formula = "='" & strWS & "'!L20"
.Cells(lastRow, 21).Value = strWS & ": "
.Cells(lastRow, 22).Formula = "='" & strWS & "'!I21"
.Cells(lastRow, 23).Formula = "='" & strWS & "'!I23"
.Cells(lastRow, 24).Formula = "='" & strWS & "'!K21"
End With
End With
End If
On Error GoTo 0
While Sheets("Global").Cells(k + 1, 17).Value = noFind(j, 0) And k < lastG
k = k + 1
Wend
Set rngCPY = Sheets("Global").Range("Q" & i & ":Q" & k).EntireRow
With Worksheets(strWS)
rngCPY.Copy
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
noFind(j, 4) = noFind(j, 4) + k - i + 1
i = k
End If
Next i
Next j
With Application: .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = True: End With
'noFind(x, y) > x = item / y: 0 = name / y: 4 = counter
noFind(0, 0) = noFind(0, 0) & " " & noFind(0, 4) & " times copied"
For i = 1 To UBound(noFind)
noFind(0, 0) = noFind(0, 0) & vbLf & noFind(i, 0) & " " & noFind(i, 4) & " times copied"
Next
MsgBox noFind(0, 0)
End Sub
At first: you may add some empty lines for better understanding...
Most parts are just shortened by view (they still do tha same).
When using the sort option, it will copy/paste all rows for each keyword in one step. That not only sounds faster... However, you may resort at the end again
Pls check if it works with your real workbook (copy of it, but with all data inside). I haven't done any "indeep speed tuning".

Answer 2

Here is a small section of your code that replace the loop through each cell in Global!Q3:Q*<last_row>* with the VBA version of the MATCH function.
Dim rw As Long, rngGQs As Range '<~~ put this closer to the top with the other variable declarations
' find last row
'lastG = Sheets("Global").Cells(Rows.Count, "Q").End(xlUp).Row '<~~old way
With Sheets("Global") '<~~new way
Set rngGQs = .Range(Cells(3, "Q"), .Cells(Rows.Count, "Q").End(xlUp)) '< ~~ all of the cells to look at
End With
If InStr(1, Sheets("Payment Form").Range("A20").Value, "THE VAT SHOWN IS YOUR OUTPUT TAX DUE TO CUSTOMS AND EXCISE") > 0 Then
If Sheets("PAYMENT FORM").Range("L40") >= 1 Then
MsgBox "It appears you have already split the jobs, this operation can only be performed once.", vbExclamation, "Invalid Operation"
Exit Sub
Else
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
'For i = 3 To lastG '<~~old way
'lookupVal = Sheets("Global").Cells(i, "Q") ' value to find
'If lookupVal = currval Then
If Not IsError(Application.Match(currval, rngGQs, 0)) Then '<~~new way
rw = Application.Match(currval, rngGQs, 0)
Set rngCPY = Sheets("Global").Cells(rw, "Q").EntireRow
'all the rest here
When you get this to a satisfactory working order, it will be a prime candidate for suggestions at Code Review (Excel).

Answer 3

You could try something like this. The Range.Find-Method basically looks through the given range for a value which you can specify. If a match is found, the cell in which the match is found, can then be stored.
You can then also use .FindNext to find the next occurrence of that value, if needed.
For j = 0 To Me.ComboBox2.ListCount - 1
currval = Me.ComboBox2.List(j, 0) ' value to match
Set rngCPY = sheets("Global").Range("Q:Q").Find(currval, LookIn:=xlValues)
Do While Not rngCPY Is Nothing
strWs = Me.ComboBox2.List(j, 1)
rngCPY.EntireRow.Copy
With Worksheets(strWS)
.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Insert shift:=xlDown
End With
Set rngCPY = sheets("Global").Range("Q:Q").FindNext(rngCPY)
Loop
Next j