当列的填充行少于2行时，复制/粘贴直到最后一行VBA代码不起作用

Question

我对VBA比较陌生，所以请多多包涵。

我正在尝试编写VBA代码，以帮助我将多列中的数据复制和粘贴到另一张纸上的单个列中。

我当前的代码能够复制数据直到最后填充的行，并将其粘贴到每次迭代的最后填充的条目之后。但是，当随后的列为空白或只有1个填充行时，代码将完全停止运行。谁能帮我弄清楚为什么会这样吗？

Sub FirstVBA()
    Dim Criteria As Integer
    Criteria = Range("G1").Value

    If Criteria <> 0 Then
        Worksheets("Sheet2").Range("A2:A" & Rows.Count).Clear

        Worksheets("Sheet1").Range("B4", Range("B4").End(xlDown)).Copy
        Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

        Worksheets("Sheet1").Range("C4", Range("C4").End(xlDown)).Copy
        Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

        Worksheets("Sheet1").Range("D4", Range("D4").End(xlDown)).Copy
        Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

        Worksheets("Sheet1").Range("E4", Range("E4").End(xlDown)).Copy
        Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

        Worksheets("Sheet1").Range("F4", Range("F4").End(xlDown)).Copy
        Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

        Worksheets("Sheet1").Range("G4", Range("G4").End(xlDown)).Copy
        Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

        Worksheets("Sheet1").Range("H4", Range("H4").End(xlDown)).Copy
        Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

        Worksheets("Sheet1").Range("I4", Range("I4").End(xlDown)).Copy
        Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    End If
End Sub