使用 VBA 合并 Excel 表格

Merge Excel Sheets Using VBA

提问by

I have a Excel Sheet(Say OG.xls) which has some data already in it with some 5000 rows with headings in the first row and Upto "AN" Columns. This No of rows(5000) doesn't change for a whole year. Now i have 5 XL files(Say A,B,C,D,E) and the data from these files has to be appended to this OG file just starting from 5001st row every time. All these 5 files has different no of columns but identical to that of OG File. I have to pull data from these files and place them in OG File. From File A : Column A,B,C,D,E,F,G&H goes to Column F,G,T,U,V,W,X&Y Of OG.xls File. Likewise the other files data has to be extracted according to the corresponding column with OG.xls

我有一个 Excel 工作表（比如 OG.xls），其中已经有一些数据，其中有大约 5000 行，第一行有标题，最多为“AN”列。此行数（5000）一整年都不会改变。现在我有 5 个 XL 文件（比如 A、B、C、D、E），并且每次都必须将这些文件中的数据从第 5001 行开始附加到这个 OG 文件中。所有这 5 个文件的列数不同，但与 OG 文件的列数相同。我必须从这些文件中提取数据并将它们放在 OG 文件中。从文件 A：A、B、C、D、E、F、G&H 列转到 OG.xls 文件的 F、G、T、U、V、W、X&Y 列。同样，其他文件数据必须根据 OG.xls 对应的列提取

The second file data has to be appended right below the next row where the File A ends.(Say after filling the data from File A now the OG.xls has 5110 rows, the File B data has to filled from 5111 st row of OG.xls. The same follows for the other files too. The data of these 5 files has to be filled row after row but should match the columns to that of OG.xls

第二个文件数据必须附加在文件 A 结束的下一行的正下方。（假设现在从文件 A 填充数据后 OG.xls 有 5110 行，文件 B 数据必须从 OG 的第 5111 行填充.xls. 其他文件也一样. 这5个文件的数据要逐行填写，但要与OG.xls的列匹配

Each time the same operation is repeated by filling the data from 5001st row of OG.xls. For convenience we can have all these files in a same folder.

每次通过填充 OG.xls 的第 5001 行的数据来重复相同的操作。为方便起见，我们可以将所有这些文件放在同一个文件夹中。

How can we do this.

我们应该怎么做。

Please help me in this!!! Also let me know for any clarifications.

请帮我解决这个问题！！！也让我知道任何澄清。

回答by Dheer

If you need a more presice answer, you would need to try something first and then ask for help in area you have got stuck. My suggestion is you begin by; 1. Start writing a VBA script in OG.XLS, as a first step try to access the file A.xls and reading the columns and pasting them (they can initially be at any location in any order). 2. Once you are able to do this, next step is to see if you put the data in right column (say 5000 in your example) by setting up right kind of variables and using them and incrementing them. 3. Your next step should be to to read the column headings in A.XLS and finding them OG.XLS and identifying them. Initially you can begin by doing a simple string comparision, later you can refine this to do a VLOOKUP. 4. During this process, if you encounter any specific problem, raise it so that you will get a better answer.

如果你需要一个更准确的答案，你需要先尝试一些东西，然后在你遇到困难的地方寻求帮助。我的建议是你开始; 1. 开始在 OG.XLS 中编写 VBA 脚本，作为第一步尝试访问文件 A.xls 并读取列并粘贴它们（它们最初可以以任何顺序位于任何位置）。2. 一旦你能够做到这一点，下一步就是通过设置正确类型的变量并使用它们并增加它们来查看是否将数据放在正确的列中（例如在你的例子中为 5000）。3. 下一步应该是阅读 A.XLS 中的列标题并找到它们 OG.XLS 并识别它们。最初，您可以从进行简单的字符串比较开始，稍后您可以对其进行改进以进行 VLOOKUP。4. 在此过程中，如果遇到具体问题，请提出，以便得到更好的答案。

Few from the community would go to the extent of writing the entire code for you.

社区中很少有人会为您编写整个代码。

回答by Mark Nold

Why does Column A end up in Column F, and why does C end up in T? Is there a rule around this such as the first row is a header with with the same text in it?

为什么A列在F列结束，C为什么在T列结束？是否有围绕此的规则，例如第一行是包含相同文本的标题？

Maybe a picture might help.

也许一张图片可能会有所帮助。

Based on what i can guess, i'd throw each sheet into a RecordSet with meaningful field names (you'll need to reference Microsoft ActiveX Data Objects 2.8 Library) . Once done it will be very easy to append each RecordSet and throw them into a single sheet.

根据我的猜测，我会将每个工作表放入具有有意义的字段名称的 RecordSet 中（您需要参考Microsoft ActiveX Data Objects 2.8 Library）。完成后，将很容易附加每个 RecordSet 并将它们放入单个工作表中。

You'll need to be able to find the last column and last row in each sheet to do this cleanly so have a look at How can i find the last row...

您需要能够在每个工作表中找到最后一列和最后一行才能干净利落地执行此操作，因此请查看如何找到最后一行...

Edit...

编辑...

Below is a cleaned up example of how you could do what you need in VBA. The devil is in the details such as empty sheets, and how to handle formulas (this ignores them completely), and how to merge you columns in an appropriate way (again ignored).

下面是一个清理示例，说明如何在 VBA 中执行所需操作。问题在于细节，例如空表，以及如何处理公式（这完全忽略了它们），以及如何以适当的方式合并列（再次被忽略）。

This has been tested in Excel 2007.

这已经在 Excel 2007 中进行了测试。

Option Explicit
Const MAX_CHARS = 1200



Sub MergeAllSheets()
  Dim rs As Recordset
  Dim mergedRS As Recordset
  Dim sh As Worksheet
  Dim wb As Workbook

  Dim fieldList As New Collection
  Dim rsetList As New Collection

  Dim f As Variant
  Dim cols As Long
  Dim rows As Long
  Dim c As Long
  Dim r As Long

  Dim ref As String
  Dim fldName As String
  Dim sourceColumn As String



  Set wb = ActiveWorkbook
  For Each sh In wb.Worksheets
    Set rs = New Recordset
    ref = FindEndCell(sh)
    cols = sh.Range(ref).Column
    rows = sh.Range(ref).Row

    If ref <> "$A" Or sh.Range(ref).Value <> "" Then '' This is to catch empty sheet
      c = 1
      r = 1
      Do While c <= cols
        fldName = sh.Cells(r, c).Value
        rs.Fields.Append fldName, adVarChar, MAX_CHARS
        If Not InCollection(fieldList, fldName) Then
          fieldList.Add fldName, fldName
        End If
        c = c + 1
      Loop
      rs.Open


      r = 2
      Do While r <= rows
        rs.AddNew
        c = 1
        Do While c <= cols
          rs.Fields(c - 1) = CStr(sh.Cells(r, c).Value)
          c = c + 1
        Loop
        r = r + 1
        Debug.Print sh.Name & ": " & r & " of " & rows & ", " & c & " of " & cols
      Loop
      rsetList.Add rs, sh.Name
    End If
  Next


  Set mergedRS = New Recordset
  c = 1
  sourceColumn = "SourceSheet"
  Do While InCollection(fieldList, sourceColumn) '' Just in case you merge a merged sheet
    sourceColumn = "SourceSheet" & c
    c = c + 1
  Loop
  mergedRS.Fields.Append sourceColumn, adVarChar, MAX_CHARS
  For Each f In fieldList
    mergedRS.Fields.Append CStr(f), adVarChar, MAX_CHARS
  Next
  mergedRS.Open

  c = 1
  For Each rs In rsetList
    If rs.RecordCount >= 1 Then
      rs.MoveFirst
      Do Until rs.EOF
        mergedRS.AddNew
        mergedRS.Fields(sourceColumn) = "Sheet No. " & c
        For Each f In rs.Fields
          mergedRS.Fields(f.Name) = f.Value
        Next
        rs.MoveNext
      Loop
    End If
    c = c + 1
  Next


  Set sh = wb.Worksheets.Add

  mergedRS.MoveFirst
  r = 1
  c = 1
  For Each f In mergedRS.Fields
    sh.Cells(r, c).Formula = f.Name
    c = c + 1
  Next

  r = 2
  Do Until mergedRS.EOF
    c = 1
    For Each f In mergedRS.Fields
      sh.Cells(r, c).Value = f.Value
      c = c + 1
    Next
    r = r + 1
    mergedRS.MoveNext
  Loop
End Sub

Public Function InCollection(col As Collection, key As String) As Boolean
  Dim var As Variant
  Dim errNumber As Long

  InCollection = False
  Set var = Nothing

  Err.Clear
  On Error Resume Next
    var = col.Item(key)
    errNumber = CLng(Err.Number)
  On Error GoTo 0

  '5 is not in, 0 and 438 represent incollection
  If errNumber = 5 Then ' it is 5 if not in collection
    InCollection = False
  Else
    InCollection = True
  End If

End Function


Public Function FindEndCell(sh As Worksheet) As String
  Dim cols As Long
  Dim rows As Long
  Dim maxCols As Long
  Dim maxRows As Long
  Dim c As Long
  Dim r As Long

  maxRows = sh.rows.Count
  maxCols = sh.Columns.Count

  cols = sh.Range("A1").End(xlToRight).Column
  If cols >= maxCols Then
      cols = 1
  End If


  c = 1
  Do While c <= cols

    r = sh.Cells(1, c).End(xlDown).Row
    If r >= maxRows Then
      r = 1
    End If

    If r > rows Then
      rows = r
    End If
    c = c + 1
  Loop

  FindEndCell = sh.Cells(rows, cols).Address

End Function