代码之家 › 专栏 › 技术社区 › mabanalyst

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

vba excel

mabanalyst · 技术社区 · 2 年前

我的目标是将40多个Excel工作表中的一系列列(a:C)自动复制到同一工作簿中的一个工作表中。

所有板材的结构都是相同的。列由数值组成。我希望在每次迭代时将列添加到右侧(这样目标工作表将用数据横向充实)

我的尝试(见下面的代码)不是自动的,好像我必须指定工作表名称和目标单元格,以便可以复制列

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

感谢您的帮助!非常感谢。

1 回复 | 直到 2 年前

FaneDuru 2 年前

请尝试下一个代码。它将在所有现有图纸之间迭代,并从一个名为“目的地”(从“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

推荐文章