运行时错误7：内存不足，加速代码
我一直在解决这个问题已经有一段时间了，在这里的人们的帮助下，我设法提出了两个解决scheme。
第一个解决scheme工作，但我不能得到msgbox显示正确的信息。
下面的版本第一次工作， msgbox在msgbox中显示正确的数据，但如果我再次尝试运行代码，它会崩溃excel，并给我一个运行时错误7：内存不足。 它打破了： wsNew.Name = strWS ，它看起来总是试图创build工作表，即使他们已经存在。
我认为这可能与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
我想要它显示的内容：随着全球search总行数，即如果有43行全球。 然后，siplay未被复制的行的值（如果适用的话），例如，如果全局表的Q列中有一个BRERROR消息框也会说：发现的错误：＆vblf cell.value（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 （但保持多个复制/粘贴），以检查错过的行…这段代码假设有没有在列表框双打（如果有，这将复制/粘贴，我不认为这是通缉）
然而，它现在应该是你想要的:)
关于你的要求：
虽然这正是我真正喜欢的那种工作，但是您应该考虑一些问题：
1：总而言之，我是一个坏人（只会帮助你欺骗你），利用这些数据来伤害你或你的公司。
2：数据本身可能被视为“商业秘密”，将其交给某人可能会给你带来很大的麻烦。 （无愧＃1）
3：一般人因为做这种工作而得到报酬 ，这会使我陷入困境。
4：即使拥有所有的数据，也没有告诉我最终需要如何。 （你需要向我解释每一个单一的位）
5：你需要了解我所做的或者你依赖我。
至less，在优化代码时，你应该阅读这样或者这样的东西。