CODEWITHSUNDEEP
performancevbaexcelruntime-error
atame
atame

Reputation: 521

Run-time error 7: out of memory & speed up code

I have been working on this problem for some time now and with help from people on here I have managed to come up with two variant to the problem.

The first solution works, but i cannot get the msgbox at the end to display the correct information.

The version below works the first time and displays the correct data in the msgbox at the end, but if I try and run the code again, it crashes excel, and give me a run-time error 7: out of memory. It breaks at: wsNew.Name = strWS, it looks like it is always trying to create the sheets even though they already exists.

I think it might have something to do with On Error Resume Next, If Len(Worksheets(strWS).Name) = 0 Then.

Is it possible to speed this code up in anyway? currently it is looking through 42 rows in the Global sheet but there may be instance where it is in the hundreds, while it is running at a reasonable speed at the moment, as soon as i introduce more rows in the global sheet it will begin to slow down.

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

Changes to DirkReichel Code:

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

What i want it to display: Along with the total number of rows search in Global, i.e if there were 43 rows in global. Then siplay the value of the row that wasn't copied (if applicable) for instance if there was a BRERROR in column Q of the Global sheet the message box would also say: Errors found: &vblf cell.value (1)

enter image description here

Upvotes: 0

Views: 229

Answers (2)

Dirk Reichel
Dirk Reichel

Reputation: 7979

Regarding your request:

While this is exactly that kind of work i really like, there some problems you should consider:

1: There is allways the possibility I'm a bad guy (who is only helping you to trick you at the end) using the data providet to harm you or your company.

2: The data itself may be counted as "business secret" and giving it to someone may get you in real big trouble. (regardeless of #1)

3: Normally people get paid for doing this kind of work, which can get me into trouble.

4: Even having all the data, doesn't tell me how it needs to be at the end. (You would need to explain EVERY single bit to me)

5: You would need understand what i've done or you were dependent on me.

At least, when optimizing code you should read something like this or this.

Upvotes: 0

Dirk Reichel
Dirk Reichel

Reputation: 7979

EDITED AGAIN this is a big workover, you need to copy the whole code!

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

switched i and j again (but kept the multi copy/paste) to check for missed lines... this code asumes that there are no doubles in the listbox (if there are, that would double copy/paste and i dont think that is wanted)

however, it now should be as you want it:)

Upvotes: 1

Related Questions