Question

我一直在研究这个问题已有一段时间了，在这里的人们的帮助下，我已经设法找到了两个问题的变种。

第一种解决方案有效，但我无法在最后获得msgbox来显示正确的信息。

下面的版本第一次运行并在最后的msgbox中显示正确的数据，但如果我再次尝试运行代码，它会崩溃excel，并给我一个运行时错误7：内存不足。它打破了：wsNew.Name = strWS，看起来它总是试图创建工作表，即使它们已经存在。

我认为这可能与On Error Resume Next, If Len(Worksheets(strWS).Name) = 0 Then有关。

是否可以加速此代码？目前它正在查看全局表单中的42行，但可能存在数百个实例，而目前它以合理的速度运行，只要我在全局表单中引入更多行，它就会开始慢下来。

Private Sub CommandButton2_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

  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, "Q").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

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .CutCopyMode = False
    .EnableEvents = False
End With

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 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
                    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
                    Dim wsTemplate As Worksheet: Set wsTemplate = ThisWorkbook.sheets("Template")
                    Dim wsNew As Worksheet
                    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
                      wsTemplate.Visible = True
                      wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
                      wsTemplate.Visible = False
  CODE BREAKS HERE -> wsNew.Name = strWS
                      wsNew.Range("D4").value = sheets("Payment Form").Range(strRng).End(xlDown).value
                      wsNew.Range("D6").value = sheets("Payment Form").Range("L11").value
                      wsNew.Range("D8").value = sheets("Payment Form").Range("C9").value
                      wsNew.Range("D10").value = sheets("Payment Form").Range("C11").value
                    End With
                    With ThisWorkbook.sheets("Payment Form")
                      .Activate
                      .Range("J" & lastRow2 + 1).value = 0
                      .Range("L" & lastRow2 + 1).Formula = "=N" & lastRow2 + 1 & "-J" & lastRow2 + 1 & ""
                      .Range("N" & lastRow2 + 1).Formula = "='" & strWS & "'!L20"
                      .Range("U" & lastRow + 1).value = strWS & ": "
                      .Range("V" & lastRow + 1).Formula = "='" & strWS & "'!I21"
                      .Range("W" & lastRow + 1).Formula = "='" & strWS & "'!I23"
                      .Range("X" & lastRow + 1).Formula = "='" & strWS & "'!K21"
                    End With
                    End With
                    End If
                    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

    If sSheetsWithData <> vbNullString Then
        sOutput = "# of rows copied to sheets:" & vbLf & vbLf & sSheetsWithData & vbLf & _
            "Total rows copied = " & lAllRowsCopied & vbLf & vbLf
    End If

    If sOutput <> vbNullString Then MsgBox sOutput, , "Copy Report"

    Set rngCPY = Nothing

  With Application: .ScreenUpdating = True: .EnableEvents = True: .CutCopyMode = True: End With

End Sub

对DirkReichel代码的更改：

Private Sub CommandButton3_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 wsTemplate As Worksheet: Set wsTemplate = ThisWorkbook.sheets("Template")
         -> Dim wsNew As Worksheet
            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
         -> wsTemplate.Visible = True
         -> wsTemplate.Copy before:=sheets("Details"): Set wsNew = ActiveSheet
         -> wsTemplate.Visible = False
            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

我希望它显示的内容：连同在Global中搜索的总行数，即全局中有43行。然后siplay未复制的行的值（如果适用），例如，如果Global表中的Q列中有BRERROR，则消息框也会说：发现错误：＆amp; vblf cell.value（1）< / p>

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
  Dim noFound As Variant: ReDim noFound(1, 0): noFound(0, 0) = ""
  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 i = 3 To lastG
    For j = 0 To UBound(noFind)
      If Not IsNumeric(noFind(j, 4)) Then noFind(j, 4) = 0
      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
            Err.Clear
            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
        Exit For
      End If
    Next j
    With Sheets("Global").Cells(i, 17)
      If j > UBound(noFind) Then
        k = i
        While Sheets("Global").Cells(k + 1, 17).Value = .Value And k < lastG
          k = k + 1
        Wend
        If Len(noFound(0, 0)) = 0 Then
          noFound(0, UBound(noFound, 2)) = .Value
          noFound(1, UBound(noFound, 2)) = k - i + 1
        Else
          For j = 0 To UBound(noFound, 2)
            If noFound(0, j) = .Value Then
              noFound(1, j) = noFound(1, j) + k - i + 1
              Exit For
            End If
          Next
          If j > UBound(noFound, 2) Then
            ReDim Preserve noFound(1, UBound(noFound, 2) + 1)
            noFound(0, UBound(noFound, 2)) = .Value
            noFound(1, UBound(noFound, 2)) = k - i + 1
          End If
        End If
      End If
    End With
  Next i
  noFind(0, 3) = 0
  noFind(0, 5) = ""
  For i = 0 To UBound(noFind)
    If noFind(i, 4) > 0 Then
      noFind(0, 5) = noFind(0, 5) & noFind(i, 1) & " (" & noFind(i, 4) & ")" & vbLf
      noFind(0, 3) = noFind(0, 3) + noFind(i, 4)
    End If
  Next
  If noFind(0, 3) = 0 Then
    strWS = "No matches found!" & vbLf
  Else
 -->strWS = "# of rows copied to sheets:" & vbLf & vbLf & noFind(0, 5) & vbLf & "Total lines copied: " & noFind(0, 3) & " of " & lastG - 2
  End If
  If Len(noFound(0, 0)) Then
    strWS = strWS & vbLf & vbLf & "Missed Lines in Global: " & vbLf & vbLf
    For i = 0 To UBound(noFound, 2)
      strWS = strWS & noFound(0, i) & " (" & noFound(1, i) & ")" & vbLf
    Next i
  End If
  With Application: .ScreenUpdating = True: .EnableEvents = True: End With
  MsgBox strWS
End Sub

再次切换i和j（但保留多重复制/粘贴）以检查错过的行...此代码假设列表框中没有双打（如果有，那么将双重复制/粘贴，我不认为这是想要的）

然而，它现在应该如你所愿：）

Answer 2

关于您的请求：

虽然这正是我真正喜欢的那种工作，但你应该考虑一些问题：

1：总有可能我是一个坏人（他只是帮你最后欺骗你）使用数据提供来伤害你或你的公司。

2：数据本身可能被视为＆＃34;商业秘密＆＃34;把它交给某人可能会让你陷入困境。（无论是＃1）

3：通常人们会paid做这种工作，这会让我遇到麻烦。

4：即使拥有所有数据，也不会告诉我最终需要的是什么。（您需要向我解释每一位）

5：你需要了解我所做的事情，或者你依赖我。

至少，在优化代码时，您应该阅读this或this之类的内容。

运行时错误7：内存不足＆amp;加快代码

2 个答案: