将单元格值与combobox行值匹配
我试图找出一个不同的方法来运行一段代码。
基本上我的代码正在做的是，循环虽然在全球表中的列Q，然后通过Combobox2循环，当它发现匹配时，整个行被移动到combobox1列中的工作表引用。
是否有可能使用匹配function来实现相同的结果，加快代码？
这是目前我正在使用的代码，它做我需要做的，但我不能得到error handling工作。 而且它有很多行数据循环可能需要很长时间！
选项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 选项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
好的…这更像是一个尝试，而不是一个答案。 请检查，如果这是工作，如果它更快。
使用此macros只与您的工作簿的副本 ！
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
起初：您可以添加一些空行，以更好地理解…
大部分部分只是缩小视图（他们仍然这样做）。
使用sorting选项时，它将一步复制/粘贴每个关键字的所有行。 这不仅听起来更快……但是，你可能会再次诉诸于结尾
请检查它是否适用于您的真实工作簿（复制它，但与所有数据里面）。 我没有做任何“速度调整”。
这里是你的代码的一小部分，代替Global！Q3：Q * <last_row> *中的每个单元的循环与MATCH函数的VBA版本。
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
当你把这件事情交给一个令人满意的工作订单时，它将成为代码审查（Excel）build议的主要候选人。
你可以尝试这样的事情。 Range.Find方法基本上查看给定的范围，可以指定一个值。 如果find匹配，则可以存储find匹配的单元格。
如果需要的话，您也可以使用.FindNext查找该值的下一次出现。
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