excel - 从所有工作表中复制范围并将它们粘贴到新的工作表中

Question

请帮助我，我需要复制不同的范围，直到所有工作表中的第一个空白单元格并将它们粘贴到新的单元格中。都在同一个Workbook .
这是我的尝试:

Sub Target()

   Dim lRow As Long
   Dim copyRange As Range
    Dim sh As Worksheet
    Dim shReport As Worksheet
    Set shReport = ThisWorkbook.Worksheets("Target")

    For Each sh In ThisWorkbook.Worksheets
        Select Case sh.Name
            Case Is <> "ALLProjectForReport"
                lRow = shReport.Cells(Rows.Count, "B").End(xlUp).Row
               Set copyRange = sh.Range("A3")

               copyRange.Copy Destination:=shReport.Range("B" & lRow)

        End Select
    Next
    Set shReport = Nothing
    Set sh = Nothing
End Sub

Answer 1

堆叠部分列 ( xlDown )

Option Explicit

Sub createReport()

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim dst As Worksheet: Set dst = wb.Worksheets("Target")
    Dim cel As Range
    Set cel = dst.Cells(dst.Rows.Count, "B").End(xlUp).Offset(1)

    Dim src As Worksheet
    Dim rng As Range
    For Each src In wb.Worksheets
        Select Case src.Name
            Case "AllProjectForReport", "Target"
            Case Else
                With src.Range("A3")
                    Set rng = .End(xlDown)
                    If rng.Row < src.Rows.Count Then
                        Set rng = .Resize(rng.Row - .Row + 1)
                    Else
                        If Len(.Value) > 0 Then
                            Set rng = .Offset
                        Else
                            Set rng = Nothing
                        End If
                    End If
                    If Not rng Is Nothing Then
                        rng.Copy Destination:=cel
                        Set cel = cel.Offset(rng.Rows.Count)
                    End If
                End With
        End Select
    Next
  
    MsgBox "Report created.", vbInformation, "Success"

End Sub