VBA Code Fix: Appending All Rows to New Sheet, but One Row of Each is Missing

[bklmabry]

I was so proud when I modified the VBA code from JLGWhiz' reply to "VBA: Copy all rows with data from one sheet and paste on bottom of another" from this forum in order to copy/paste the rows from ten sheets, and it looked at first glance like it worked!

On closer inspection, I found that the final list of rows contained one less row per worksheet it copied from; i.e. worksheet 1 contains 13 rows but only 12 were copied. I'm sure there's something that needs to be tweaked in the code, but I'm only just learning VBA and can't quite root it out.

The original code from the earlier forum was:

Sub cpynpst()
Dim sh4 As Worksheet, sh5 As Worksheet, lr As long, rng As Range
Set sh4 = Sheets("Sheet4")
Set sh5 = Sheets("Sheet5")
lr= sh4.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh4.Range("A2:A" & lr)
rng.EntireRow.Copy sh5.Cells(Rows.Count, 1).End(xlUp)(2)
End Sub

It's not the most elegant, I'm sure, but I modified it thus:

Sub cpynpst()

Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, sh4 As Worksheet, sh5 As Worksheet
Dim sh6 As Worksheet, sh7 As Worksheet, sh8 As Worksheet, sh9 As Worksheet, sh10 As Worksheet
Dim sh0 As Worksheet, lr As Long, rng As Range

Set sh1 = Sheets("1")
Set sh2 = Sheets("2")
Set sh3 = Sheets("3")
Set sh4 = Sheets("4")
Set sh5 = Sheets("5")
Set sh6 = Sheets("6")
Set sh7 = Sheets("7")
Set sh8 = Sheets("8")
Set sh9 = Sheets("9")
Set sh10 = Sheets("10")
Set sh0 = Sheets("Sum")

lr = sh1.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh1.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh2.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh2.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh3.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh3.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh4.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh4.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh5.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh5.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh6.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh6.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh7.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh7.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh8.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh8.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh9.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh9.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

lr = sh10.Cells(Rows.Count, 1).End(xlUp).Row
Set rng = sh10.Range("A2:A" & lr)
rng.EntireRow.Copy sh0.Cells(Rows.Count, 1).End(xlUp)(2)

End Sub



I'm almost certain that something in those last paragraphs is causing the module to copy one less row per worksheet or copy over prior rows in each worksheet. Can someone, maybe JLGWhiz, offer some help?

Thank you!

 

[JackDanIce]

Welcome to the board.

A guess, so test on a copy of your workbook, try:

Sub cpynpst_1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    Dim var     As Variant
    
    Application.ScreenUpdating = False
    
    For Each var In Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "Sum")
        With Sheets(CStr(var))
            x = .Cells(.Rows.Count).End(xlUp).Row
            y = .Cells(1, .Columns.Count).End(xlToLeft).Column
            arr = .Cells(1, 1).Resize(x, y).Value
            sh0.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
            Erase arr
        End With
    Next var
    
    Application.ScreenUpdating = True
    
End Sub

 

[bklmabry]

Welcome to the board.

A guess, so test on a copy of your workbook, try:

Sub cpynpst_1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    Dim var     As Variant
    
    Application.ScreenUpdating = False
    
    For Each var In Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "Sum")
        With Sheets(CStr(var))
            x = .Cells(.Rows.Count).End(xlUp).Row
            y = .Cells(1, .Columns.Count).End(xlToLeft).Column
            arr = .Cells(1, 1).Resize(x, y).Value
            sh0.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
            Erase arr
        End With
    Next var
    
    Application.ScreenUpdating = True
    
End Sub

Hey, JackDanIce

Thanks for taking the time to put this together. I ran into an error trying to run the code

http://drive.google.com/file/d/0B45R2wuerbH4eXdMQWhxRTFKQk0/view?usp=sharing

...the earlier example that I used from another forum post worked with the sole exception of truncating the list of rows to copy by one (or overwriting on the last row in the list); it was almost there! Would you happen to know how to alter the code in the above example such that it copies all the rows into the final sheet?

I thank you for any insights you might provide!

 

[JackDanIce]

Spotted the error, try

Sub cpynpst_1()

    Dim x       As Long
    Dim y       As Long
    Dim arr()   As Variant
    Dim var     As Variant
    
    Application.ScreenUpdating = False
    
    For Each var In Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "Sum")
        With Sheets(CStr(var))
            x = .Cells(.Rows.Count, 1).End(xlUp).Row
            y = .Cells(1, .Columns.Count).End(xlToLeft).Column
            arr = .Cells(1, 1).Resize(x, y).Value
            sh0.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
            Erase arr
        End With
    Next var
    
    Application.ScreenUpdating = True
    
End Sub

 

[bklmabry]

Hey, JackDanIce!

I had another error, unfortunately!

"Run-time error '424': Object required"

https://www.dropbox.com/s/4hmf9caos4qjeuh/Error01.PNG?dl=0
https://www.dropbox.com/s/6ex6c0aelv1evs1/Error02.PNG?dl=0

I'm not sure what to do!

 

[JackDanIce]

What is sh0 in the code?

 

[JackDanIce]

Try:

Sub cpynpst_1()

    Dim x       As Long
    Dim y       As Long
    Dim wksSum  As Worksheet
    Dim arr()   As Variant
    Dim var     As Variant
        
    Set wksSum = Sheets("Sum")
        
    Application.ScreenUpdating = False
    
    For Each var In Array("1", "2", "3", "4", "5", "6", "7", "8", "9", "10")
        With Sheets(CStr(var))
            x = .Cells(.Rows.Count, 1).End(xlUp).Row
            y = .Cells(1, .Columns.Count).End(xlToLeft).Column
            arr = .Cells(1, 1).Resize(x, y).Value
            wksSum.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
            Erase arr
        End With
    Next var
    
    Application.ScreenUpdating = True
    
    Set wksSum = Nothing
    
End Sub

 

[bklmabry]

This time the code returned "Run-time error '13': Type mismatch.

Do you think this is user error? For each "1', "2", "3" etc, I substituted the actual sheet name. That is the only modification I made. Is there something else you think I might be doing wrong?

Thanks, JackDanIce!

 

[JackDanIce]

I can't tell without your spreadsheet or code you're using, what line was the actual error on?

 

[JLGWhiz]

Assuming you only have the sheets to copy from and your summary sheet.

Sub cpyNpst()
Dim sh As Worksheet, lr As Long
    For Each sh In ThisWorkbook.Sheets
        If sh.Name <> "Sum" Then
            lr = sh.Cells.Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
            sh.Range("A2:A" & lr).EntireRow.Copy Sheets(Sum).Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub