时间戳

首页 > 解决方案 > 将多个工作簿中的表合并到一个主工作簿中

excel - 将多个工作簿中的表合并到一个主工作簿中

问题描述

我是 VBA 新手，正在尝试将多个工作簿中的表格组合起来并创建一个大型主工作簿。基本思想是（到目前为止我所做的）：

  1. 我创建了一个名为“Master”的空白工作簿，工作表名称为“total”，这是我要将提取的数据粘贴到的工作簿。我在此工作簿中创建了 VBA。
  2. 我有 100 多个要从中提取表的源文件。它们都在同一个目录中：“C:\Users\Documents\Test” 这些工作表被命名为“Sheet1”。
  3. 要创建主工作簿，我想找到最后一行并开始从下一个电子表格中复制新值，而我的代码目前无法正常工作。
  4. 另一个问题是来自不同工作簿的每个表都包含自己的标题（列名），我想跳过第二个文件中的标题。
  5. 这些表位于每个工作簿的 A1:N53 中。

这是我当前的代码：

Private Sub Extraction()

Application.ScreenUpdating = False

Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim LastRow As Long
Dim strExtension As String

Const strPath As String = "C:\Users\Documents\Test\"
strExtension = Dir(strPath & "*.xls*")

Do While strExtension <> ""
    Set wkbSource = Workbooks.Open(strExtension)
    With wkbSource
      LastRow = .Sheets("total").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
      .Sheets("Sheet1").Range("A1:N3" & LastRow).Copy wkbDest.Sheets("Master").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0)
        .Close savechanges:=False
    End With
    strExtension = Dir
Loop
Application.ScreenUpdating = True

End Sub

我肯定搞砸了它定位数据的位置并将其复制并粘贴到主工作簿。如果有人可以帮助我修改我的代码行，我将不胜感激。

先感谢您。

标签： excelvba

解决方案

对不起，我在旅途中写了这个脚本，所以我没有去测试它。

它几乎遵循您的要求。从主文件执行脚本。它使用 DIR() 循环遍历目录内的所有文件并调用 Resize 子过程，以获取范围“A1：N53”中的值并将其传输到主文件中。

DIR() 将遍历文件路径中的所有文件。对于每个文件，它将获取 sheet(1) range("A1:N53") 中的数据（如果您不希望包含标题，请将其更改为 range("A2:N53")。抱歉，解释有点模棱两可）

通过范围获取数据后，脚本将简单地调整范围大小并根据最后一行数将值传输到 Sheets(master)。

请让我知道它是否有效，它不是，请跟进评论并继续努力！

谢谢，

下面的脚本：

Option Explicit

Dim fpath As String
Dim fname As String

Dim wb As Workbook
Dim twb As Workbook

Dim rgSrc As Range
Dim rgDest As Range

Sub foo()
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False


  Set wb = ThisWorkbook

  fpath = "C:\Users\Documents\Test\"

  fname = Dir(fpath)


  Do While fname <> ""

      Set twb = Workbooks.Open(fpath & fname)

      Call Resize

      twb.Close
   
      fname = Dir()
    
  Loop

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


End Sub


Private Sub Resize()


    ' Get all the data in the current region?change it to "A2:N53" is you dont want header included from the files in filepath
    Set rgSrc = twb.Sheets(1).Range("A1:N53")

    'Get the range destination
    Set rgDest = wb.Sheets("Master").Cells(wb.Sheets("Master").Cells(Rows.Count, 1).End(xlUp).Row + 1, 1)

    Set rgDest = rgDest.Resize(rgSrc.Rows.Count, rgSrc.Columns.Count)
    
    rgDest.Value2 = rgSrc.Value2


End Sub

推荐阅读