将单元格值与组合框行值匹配

Question

我正试图想出一种运行一段代码的不同方法。

基本上我的代码目前正在做的是，循环遍历全局工作表中的列Q，然后循环通过Combobox2，当它找到匹配时，整个行被移动到组合框的第1列中的工作表引用。 / p>

是否可以使用Match功能来实现相同的结果并加快代码的速度？

这是我正在使用的代码，它完成了我需要它做的事情，但我无法让错误处理工作。它有很多行数据可以循环使用它可能需要很长时间！

选项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

Answer 1

好的......这更像是尝试而不是答案。请检查它是否有效以及是否更快。

  

仅将此宏用于工作簿的副本！

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

首先：您可以添加一些空行以便更好地理解......

大多数部分只是缩短了视图（它们仍然相同）。

使用排序选项时，它会在一个步骤中复制/粘贴每个关键字的所有行。这不仅听起来更快......但是，你可以再次使用

请检查它是否适用于您的真实工作簿（它的副本，但内部包含所有数据）。我还没有完成任何＆＃34;非常速度调整＆＃34;。

Answer 2

你可以尝试这样的事情。 Range.Find-Method基本上查看给定范围，您可以指定一个值。如果找到匹配项，则可以存储找到匹配项的单元格。

如果需要，您还可以使用.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

Answer 3

以下是代码的一小部分，用于替换全局中每个单元格的循环！Q3：Q *＆lt; last_row＆gt; *以及MATCH function的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

当您获得满意的工作订单时，它将成为Code Review (Excel)建议的主要候选人。