运行时错误7:内存不足并加速代码

阿塔米

我已经在这个问题上工作了一段时间了,在这里的人们的帮助下,我设法提出了两种解决方案。

第一个解决方案有效,但是我无法msgbox最后显示正确的信息。

下面的版本是第一次工作,并msgbox在末尾显示正确的数据,但是如果我尝试再次运行代码,它将导致excel崩溃,并给我一个运行时错误7:内存不足。它在以下位置中断:wsNew.Name = strWS,即使它们已经存在,它似乎总是在尝试创建工作表。

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

是否有可能以任何方式加快此代码的速度?目前,它正在遍历Global工作表中的42行,但是有时它会以数百行的速度运行,而当它以合理的速度运行时,只要我在Global工作表中引入更多的行,它就会开始慢下来。

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

我要显示的内容:连同在全局中搜索的总行数,即全局中是否有43行。然后显示未复制的行的值(如果适用),例如,如果“全局”表的Q列中存在BRERROR,则消息框还会显示:发现错误:&vblf cell.value(1)

在此处输入图片说明

德克·雷切尔(Dirk Reichel)

再次编辑,这是一个很大的工作,您需要复制整个代码!

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

切换ij试(但保留了多复制/粘贴),以检查是否有遗漏线...此代码asumes有在列表框中没有双打(如果有,那将增加一倍复制/粘贴,我不认为这是希望)

但是,现在应该如您所愿:)

本文收集自互联网,转载请注明来源。

如有侵权,请联系 [email protected] 删除。

编辑于
0

我来说两句

0 条评论
登录 后参与评论

相关文章

新问题-运行时错误-内存不足

运行时:内存不足,还有静态内存

如何修复 PyTorch 运行时错误:CUDA 错误:内存不足?

Perl:在运行时构建二维数组时出现内存不足错误

为什么以下golang程序会抛出运行时内存不足错误?

如何解决UPC运行时错误:共享内存不足

PyTorch 运行时错误:CUDA 内存不足。尝试分配 14.12 GiB

Eclipse 中 Java 运行时环境的内存不足

如何修复运行时错误'7'的内存不足,即使保存,关闭和重新启动计算机后,该错误仍然存在

Excel VBA Selenium打开本地网页运行时错误以及内存不足错误

作为服务运行时内存不足的永久性空间

我收到一个致命错误:运行时:使用'go-ipfs-api'下载视频时内存不足

流星应用程序运行时出现pm2严重错误:CALL_AND_RETRY_LAST分配失败-JavaScript堆内存不足

运行时错误:CUDA 内存不足。尝试分配 754.00 MiB(GPU 0;2.00 GiB 总容量;已分配 1.21 GiB ...)

jboss抛出内存不足:在intellij idea中运行时堆空间,但在eclipse中运行时没有

没有分页文件运行时,如何抑制Vista Home Premium中的“内存不足”警告?

得到'哇!:错误代码:内存不足'

内存不足错误,permgen,从Java 8变为Java 7

Fontconfig错误-“内存不足”

getDrawable()的内存不足错误

Java的内存不足的错误

蚂蚁内存不足错误

NetBeans内存不足错误

内存不足错误 imageview

ConnectionQueueStatsProvider的内存不足错误

ShowCaseView内存不足错误

更改事件代码在堆栈空间不足的情况下生成运行时错误“ 28”

代码C ++中的运行时错误

C ++代码中的运行时错误