VBA UsedRanges, когда 0

Question

Я пытаюсь собрать что-то вместе, где оно будет выглядеть в диапазоне столбцов, скопировать этот столбец (минус 2 строки заголовков), а затем вставить его в Sheet2 под последней использованной строкой.Проблема возникает, когда нечего копировать из диапазона в sheet1.Я думал о выражении If, используя счетчик, но я подумал, что должен быть лучший способ сделать это.Вот то, что у меня есть сейчас (извините, это немного грязно).

 Sub CopyUsedRanges()

 Dim lrow As Long
 Dim sh As Worksheet
 Dim rng As Range

 Set sh = Worksheets("Sheet1")
 On Error Resume Next

   'First
    lrow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    Set rng = sh.UsedRange.Range("A3:C" & lrow)
    Set rng = rng.Copy
    Worksheets("Sheet2").Activate
    Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    'Second
    Worksheets("Sheet1").Activate
    lrow = ActiveSheet.Cells(Rows.Count, "E").End(xlUp).Row

    Set rng = sh.UsedRange.Range("E3:G" & lrow)
    Set rng = rng.Copy
    Worksheets("Sheet2").Activate
    Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    'Third
    Worksheets("Sheet1").Activate
    lrow = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row

    Set rng = sh.UsedRange.Range("I3:K" & lrow).Offset(1, 0)
    Set rng = rng.Copy
    Worksheets("Sheet2").Activate
    Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues

    'Fourth
    Worksheets("Sheet1").Activate
    lrow = ActiveSheet.Cells(Rows.Count, "M").End(xlUp).Row

    Set rng = sh.UsedRange.Range("M3:O" & lrow)
    Set rng = rng.Copy
    Worksheets("Sheet2").Activate
    Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues


End Sub

Answer 1

Это должно дать вам то, что вам нужно:

Sub CopyUsedRanges()
    Dim lrow As Long
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet

    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")

    'First
    sh1.Activate
    lrow = sh1.Cells(Rows.Count, "A").End(xlUp).Row
    If lrow > 2 Then
        sh1.Range("A3:C" & lrow).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If

    'Second
    lrow = sh1.Cells(Rows.Count, "E").End(xlUp).Row
    If lrow > 2 Then
        sh1.Range("E3:G" & lrow).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If

    'Third
    lrow = sh1.Cells(Rows.Count, "I").End(xlUp).Row
    If lrow > 2 Then
        sh1.Range("I3:K" & lrow).Offset(1, 0).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If

    'Fourth
    lrow = sh1.Cells(Rows.Count, "M").End(xlUp).Row
    If lrow > 2 Then
        sh1.Range("M3:O" & lrow).Copy sh2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
    End If

End Sub