使用 VBA 将多个 sheet 中的列复制到同一工作簿中的一个 sheet

Question

我的目标是自动将一系列列 (A:C) 从 40+ Excel Sheet 复制到位于同一工作簿中的一个 Sheet 中。

所有 sheet 的结构都是相同的。列由数值组成。我希望在每次迭代时将列添加到右侧（因此目标 sheet 将用数据水平丰富）

我的尝试（参见下面的代码）不是自动的，因为我必须指定 Sheet 名称和目标单元格，以便可以复制列

Sub macro()
    Sheets("Top").Select
    Columns("A:C").Select
    Selection.Copy
    Sheets("Low").Select
    Range("D1").Select
    ActiveSheet.Paste
End Sub

感谢任何帮助！谢谢

Answer 1

请尝试下一个代码。它将在所有现有工作表之间进行迭代，并从一个名为“Destination”（从“A1”开始）的所有工作表中复制列“D:K”的所有行。如果您需要它从“D1”开始，则很容易调整代码：

Sub copyAllSheetsInOne()
   Dim ws As Worksheet, sh As Worksheet, lastRow As Long, lastEmptyCol As Long, i As Long
   
   Set sh = Worksheets("Destination") 'a sheet named "Destination" must exist in the workbook to be processed
   sh.cells.ClearContents             'clear its content (for cases when code run before)

   'some optimization to make the code faster:
   Application.DisplayAlerts = False: Application.EnableEvents = False
   Application.Calculation = xlCalculationManual
   'iterate between all existing sheets:
   For Each ws In ActiveWorkbook.Worksheets
        If ws.name <> "Destination" Then
            lastEmptyCol = sh.cells(1, sh.Columns.count).End(xlToLeft).Column + 1
            lastRow = ws.Range("D" & ws.rows.count).End(xlUp).row
            If lastEmptyCol = 2 Then lastEmptyCol = 1 'for the first sheet
        
            ws.Range("D1", ws.Range("K" & lastRow)).Copy sh.cells(1, lastEmptyCol)
        End If
   Next ws
   Application.DisplayAlerts = True: Application.EnableEvents = True
   Application.Calculation = xlCalculationAutomatic
End Sub

使用 VBA 将多个 sheet 中的列复制到同一工作簿中的一个 sheet

Copying columns from multiple sheets into one sheet in the same workbook using VBA

excel

vba