How can I transfer 4 tables to a summary table until last row with vba code?

Question

I have this Excel File:

I would like to copy to the last row all rows with values from each sheet, in order to have a single table in the "Resume" sheet. The other tables are on sheets "AA", "BB", "CC" and "DD" and have the same header as the Resume table.In the summary table, the pasted tables must be pasted in the first unfilled line.

My code currently:

Sub copy()


Sheets("AA").Select
Range("A2:J5").Select
Selection.copy
Sheets("RESUME").Select
Range("A2").Select
ActiveSheet.Paste
Sheets("BB").Select
Range("A2:J4").Select
Application.CutCopyMode = False
Selection.copy
Sheets("RESUME").Select
Range("A6").Select
ActiveSheet.Paste
Sheets("CC").Select
Range("A2:J7").Select
Application.CutCopyMode = False
Selection.copy
Sheets("DD").Select
Range("A5").Select
Sheets("RESUME").Select
Range("A9").Select
ActiveSheet.Paste
Sheets("DD").Select
Range("A2:J4").Select
Application.CutCopyMode = False
Selection.copy
Sheets("RESUME").Select
Range("A15").Select
ActiveSheet.Paste
Range("A1").Select
End Sub

Perhaps see [how to find the last row](https://stackoverflow.com/questions/11169445/error-in-finding-last-used-cell-in-excel-with-vba). — BigBen, May 03 '22 at 14:24

score 0 · Accepted Answer · answered May 03 '22 at 14:26

you should probably go 1 by 1, first "AA" sheet, then "BB", etc.

I'd go like this:

Sheets("AA").Activate
lrsheet = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row ' this line of code gives you the last filled line on your sheet

Worksheets("AA").Range("A2:A" & lr).Copy Worksheets("RESUME").Range("A2")
lrresume = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row ' this line of code gives you the last filled line on your resume

For next sheet i'd go like this:

Sheets("BB").Activate
lrsheet = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row
Worksheets("BB").Range("A2:A" & lr).Copy Worksheets("RESUME").Range("A" & lr)
lrresume = Cells.Find("*", Cells(1, 1), xlFormulas, xlPart, xlByRows, xlPrevious, False).Row ' updating "resume" last row

And the rest should be the same logic

Hope it helps!

score 0 · Answer 2 · answered May 03 '22 at 14:43

I would create a loop that ran through your source sheets and pasted each to the bottom of the Resume tab like this:

Sub copy_loop()

    ' loop through the sheet names
    For Each ws In Worksheets(Array("AA", "BB", "CC", "DD"))
    
        ' find the bottom of the data for that sheet, using column A to find bottom-most value
        SourceLastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        
        ' find the bottom of the data on Resume sheet, using column A to find bottom-most value
        DestinationLastRow = Worksheets("Resume").Cells(Worksheets("Resume").Rows.Count, "A").End(xlUp).Row
        
        ' Copy from the source location to the row below the last one containing data on Resume tab
        ws.Range("A2:J" & SourceLastRow).Copy Worksheets("Resume").Range("A" & DestinationLastRow + 1)
        
    Next
End Sub

How can I transfer 4 tables to a summary table until last row with vba code?

2 Answers2