0

I apologise in advance for posting a long macro. I tested the faulty portion alone (which works fine) and I can't figure out why it won't work in the full implementation.

CONTEXT: my workbook contains 2 large databases (each has its own worksheet). I need to separate each of them into portions according to one specific variable, analyse each portion and summarise the results. This is the process:

  1. transfer data from "full" worksheets to "partial" worksheets (ws1_full to ws1_part and ws2_full to ws2_part)
  2. calculate stuff with data from "partial" worksheets (ws3_calc)
  3. copy paste to a summary (ws3_results)
  4. loop till all portions have been treated

However, the macro results in a

Run-time error '1004': application-defined or object-defined error.

I've isolated the faulty code (part 4c, near the end of the macro) and tested it in a new Excel file, which worked perfectly fine. The error happens either when copying the data or addressing the range, yet I believe both are implemented correctly. The rest of the macro works as intended.

I would have preferred uploading a shorter version of the macro, but as stated, that one worked. Here is the full macro:

Sub Macro1()
'
' data analysis Macro
'

Application.ScreenUpdating = False
    
    Dim ws1_full, ws1_part, ws2_full, ws2_part, ws3_calc, ws3_results As Worksheet
    
    Set ws1_full = Worksheets("1_full")
    Set ws1_part = Worksheets("1_part")
    Set ws2_full = Worksheets("2_full")
    Set ws2_part = Worksheets("2_part")
    Set ws3_calc = Worksheets("3_calc")
    Set ws3_results = Worksheets("3_results")
    
    iMax = 1    'update this accordingly, it uses =MAX(1_full!A:A) to find the max value of i
    
    'delete the contents of the ws3_results table
    lastRow = ws3_results.Range("A" & Rows.Count).End(xlUp).Row
    If lastRow > 1 Then
        ws3_results.Range("A2:I" & lastRow).ClearContents
    End If
    
    For i = 1 To iMax
        '1. delete contents of ws1_part
        lastRow = ws1_part.Range("A" & Rows.Count).End(xlUp).Row
        If lastRow > 2 Then
            ws1_part.Range("A3:AW" & lastRow).ClearContents
        End If
        
        '2. delete contents of ws2_part
        lastRow = ws2_part.Range("A" & Rows.Count).End(xlUp).Row
        If lastRow > 2 Then
            ws2_part.Range("A3:AN" & lastRow).ClearContents
        End If
        
        '3. copy data from ws1_full to ws1_part
        lastRow = ws1_full.Range("A" & Rows.Count).End(xlUp).Row
        For j = 5 To lastRow
            lastRow2 = ws1_part.Range("A" & Rows.Count).End(xlUp).Row   
            If ws1_full.Cells(j, 1).Value = i Then
            'copy and paste
                ws1_full.Range("A" & j & ":AW" & j).Copy _
                    Destination:=ws1_part.Range("A" & lastRow2 + 1)
            End If
        Next
        '4. copy data from ws2_full to ws2_part
        'a. loop through each group in ws2_full
        For k = 1 To 36 Step [5]   'these are the index columns for each group
            lastRow = ws2_full.Cells(Rows.Count, k).End(xlUp).Row
            
            'b. loop through each row
            For j = 5 To lastRow
                lastRow2 = ws2_part.Cells(Rows.Count, k).End(xlUp).Row
                If ws2_full.Cells(j, k).Value = i Then
                    'c. copy paste
                    'THIS PART CAUSES THE RUN-TIME ERROR
                    ws2_full.Range(Cells(j, k), Cells(j, k + 4)).Copy _
                        Destination:=ws2_part.Cells(lastRow2 + 1, k)
                    'ws2_part.Cells(lastRow2 + 1, k).PasteSpecial Paste:=xlPasteValues This also doesn't work
                End If
            Next
        Next
        
        '5. copy data from ws3_calc to ws3_results
        'a. update ws3_calc values
        ws3_calc.Calculate
        
        'b. copy paste to ws3_results
        lastRow = ws3_results.Range("A" & Rows.Count).End(xlUp).Row
        ws3_results.Cells(i + 1, 1) = i
        ws3_calc.Range("A12:H12").Copy
        ws3_results.Range("B" & lastRow + 1).PasteSpecial xlPasteValues
        
    Next
    ws3_results.Range("A1").Select
    Application.ScreenUpdating = True
End Sub

I have tried all solutions to this VBA error that I found online and none have worked. Sorry for the long code.

GiRaf
  • 1
  • 1

0 Answers0