Append 单个（和多个）工作表分布在文件夹中的多个 excel 工作表上

Question

我有一个包含 19 个 Excel 工作表的文件夹，其中每个工作表包含 16 个工作表。 虽然 excel 文件的名称不同，但其中各个工作表的名称是相同的，即它们从“工作表 1”和 go 开始直到“工作表 16”。 我要做的是 append 每张纸在下一张的末尾并继续相同以获得一个新的 excel 文件，其中仅包含一张纸。 （换句话说，文件二（例如，B）中的表 1 将附加在文件一（例如，A）中的表 1 的末尾，文件三（例如，C）中的表 1 将附加在上述两个文件分别包含文件 A 和 B 中的工作表 1，依此类推，直到添加每个文件）。

我试过 VBA 代码来提取每个工作表，然后重命名每个工作表，将它们转换为 CSV 然后组合它们。 但是这个过程需要太多时间，并且有很多这样的文件夹。 如果我能获得 VBA 代码、python 代码或 R 代码来自动完成所有这些操作，我将不胜感激（其中任何一个都可以。解释和感谢，如果有的话，提前致谢） .

Answer 1

我想我知道你在追求什么。 如果是这样，我已经根据您的要求改编了一些针对类似问题编写的代码。

打开这些文件夹中的第一个并在其中创建一个启用宏的工作簿。 工作簿的名称无关紧要。

在该工作簿中，创建一个名为“工作簿”的工作表。

切换到 Visual Basic 编辑器。 我喜欢将我的代码分布在几个模块上，每个模块都有一个模块。 如果您更愿意提供只有一个Option Explicit语句，则可以将以下所有代码包含在一个模块中。

创建一个模块并将其命名为“LibExcel”。 以下代码包含我的 Excel 特定例程库中的一般例程：

Option Explicit
Public Sub FindLastRowCol(ByRef Wsht As Worksheet, ByRef RowLast As Long, _
                          ByRef ColLast As Long)

  ' Sets RowLast to the last row and ColLast to the last column with a value
  ' in worksheet Wsht.  Cells(RowLast, ColLast) need not contain a value.
  ' That is, the data in Wsht does not have to be rectangular.

  ' The motivation for coding this routine was the discovery that Find by
  ' previous row found a cell formatted as Merge and Center but Find by
  ' previous column did not. I had known that Find would miss merged
  ' cells but this was new to me.

  '   Dec16  Coded
  ' 31Dec16  Corrected handling of UserRange
  ' 15Feb17  SpecialCells was giving a higher row number than Find for
  '          no reason I could determine.  Added code to check for a
  '          value on rows and columns above those returned by Find
  ' 25Jun17  Found column with value above that found by Find. Fixed.

  Dim ColCrnt As Long
  Dim ColLastFind As Long
  Dim ColLastOther As Long
  Dim ColLastTemp As Long
  Dim ColLeft As Long
  Dim ColRight As Long
  Dim Rng As Range
  Dim RowIncludesMerged As Boolean
  Dim RowBot As Long
  Dim RowCrnt As Long
  Dim RowLastFind As Long
  Dim RowLastOther As Long
  Dim RowLastTemp As Long
  Dim RowTop As Long

  With Wsht

    Set Rng = .Cells.Find("*", .Range("A1"), xlFormulas, , xlByRows, xlPrevious)
    If Rng Is Nothing Then
      RowLastFind = 0
      ColLastFind = 0
    Else
      RowLastFind = Rng.Row
      ColLastFind = Rng.Column
    End If

    Set Rng = .Cells.Find("*", .Range("A1"), xlValues, , xlByColumns, xlPrevious)
    If Rng Is Nothing Then
    Else
      If RowLastFind < Rng.Row Then
        RowLastFind = Rng.Row
      End If
      If ColLastFind < Rng.Column Then
        ColLastFind = Rng.Column
      End If
    End If

    Set Rng = .Range("A1").SpecialCells(xlCellTypeLastCell)
    If Rng Is Nothing Then
      RowLastOther = 0
      ColLastOther = 0
    Else
      RowLastOther = Rng.Row
      ColLastOther = Rng.Column
    End If

    Set Rng = .UsedRange
    If Rng Is Nothing Then
    Else
      If RowLastOther < Rng.Row + Rng.Rows.Count - 1 Then
        RowLastOther = Rng.Row + Rng.Rows.Count - 1
      End If
      If ColLastOther < Rng.Column + Rng.Columns.Count - 1 Then
        ColLastOther = Rng.Column + Rng.Columns.Count - 1
      End If
    End If

    If RowLastFind < RowLastOther Then
      ' Higher row found by SpecialCells or UserRange
      Do While RowLastOther > RowLastFind
        ColLastTemp = .Cells(RowLastOther, .Columns.Count).End(xlToLeft).Column
        If ColLastTemp > 1 Or .Cells(RowLastOther, 1).Value <> "" Then
          Debug.Assert False
          ' Is this possible
          ' Row after RowLastFind has value
          RowLastFind = RowLastOther
          Exit Do
        End If
        RowLastOther = RowLastOther - 1
      Loop
    ElseIf RowLastFind > RowLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    RowLast = RowLastFind

    If ColLastFind < ColLastOther Then
      ' Higher column found by SpecialCells or UserRange
      Do While ColLastOther > ColLastFind
        RowLastTemp = .Cells(.Rows.Count, ColLastOther).End(xlUp).Row
        If RowLastTemp > 1 Or .Cells(1, ColLastOther).Value <> "" Then
          'Debug.Assert False
          ' Column after ColLastFind has value
          ' Possible causes:
          '   * Find does not recognise merged cells
          '   ' Find does not examine hidden cells
          ColLastFind = ColLastOther
          Exit Do
        End If
        ColLastOther = ColLastOther - 1
      Loop
    ElseIf ColLastFind > ColLastOther Then
      Debug.Assert False
      ' Is this possible
    End If
    ColLast = ColLastFind

  End With

End Sub
Public Function WshtExists(ByRef Wbk As Workbook, ByVal WshtName As String)

  ' Returns True if Worksheet WshtName exists within
  '  * if Wbk Is Nothing the workbook containing the macros
  '  * else workbook Wbk

  ' 21Aug16  Coded by Tony Dallimore
  ' 14Feb17  Coded alternative routine that cycled through the existing worksheets
  '          matching their names against WshtName to check use of "On Error Resume Next"
  '          was the faster option. I needed to call the routines 6,000,000 times each to
  '          get an adequate duration for comparison. This version took 33 seconds while
  '          the alternative took 75 seconds.

  Dim WbkLocal As Workbook
  Dim Wsht As Worksheet

  If Wbk Is Nothing Then
    Set WbkLocal = ThisWorkbook
  Else
    Set WbkLocal = Wbk
  End If

  Err.Clear
  On Error Resume Next
  Set Wsht = WbkLocal.Worksheets(WshtName)
  On Error GoTo 0
  If Wsht Is Nothing Then
    WshtExists = False
  Else
    WshtExists = True
  End If

End Function

此代码属于“ModPrepare”模块。 注意“Mod”很重要。 该模块包含一个宏“准备”。 如果你给一个模块和一个宏赋予相同的名称，你会得到模糊的错误。

Option Explicit
Sub Prepare()

  ' Create list of workbooks (other than this workbook) in current folder

  Dim Path As String
  Dim RowWbks As Long
  Dim WbkName As String

  Path = ThisWorkbook.Path & "\"

  With Worksheets("Workbooks")
    .Cells.EntireRow.Delete
    .Cells(1, 1).Value = "New workbook"
    .Cells(1, 2).Value = "Existing workbooks"
    .Range("A1:B1").Font.Bold = True

    RowWbks = 2

    WbkName = Dir$(Path & "*.xls*", vbNormal)

    Do While WbkName <> ""
      If WbkName <> ThisWorkbook.Name Then
        .Cells(RowWbks, 2).Value = WbkName
        RowWbks = RowWbks + 1
      End If
      WbkName = Dir$
    Loop

    .Columns.AutoFit

  End With

End Sub

此代码属于“ModMerge”模块：

Option Explicit
  Const RowSrcDataFirst As Long = 3
Sub Merge()

  Dim ColCrnt As Long        ' Current column in either current worksheet
  Dim ColDestLast As Long    ' Last column in current destination worksheet
  Dim ColSrcLast As Long     ' Last column in current source worksheet
  Dim NumShtCrnt As Long     ' Number of current worksheet in source and destination workbooks
  Dim Path As String         ' Folder holding workbooks
  Dim RngSrc As Range        ' Range to be copied from current source worksheet
  Dim RowDestLast As Long    ' Last row in current destination worksheet
  Dim RowSrcCrnt As Long     ' Current row in current source worksheet
  Dim RowSrcLast As Long     ' Last row in current source worksheet
  Dim RowWbksCrnt As Long    ' Current row in worksheet "Workbooks"
  Dim WbkDest As Workbook    ' Reference to destination workbook
  Dim WbkSrc As Workbook     ' Reference to source workbook
  Dim WbkDestName As String  ' Name of destination workbook
  Dim WbkSrcName As String   ' Name of current source workbook
  Dim WshtDest As Worksheet  ' Reference to current destination worksheet
  Dim WshtSrc As Worksheet   ' Reference to current source worksheet
  Dim WshtWbks As Worksheet  ' Reference to worksheet "Workbooks"

  Application.ScreenUpdating = False

  Set WshtWbks = ThisWorkbook.Worksheets("Workbooks")
  Path = ThisWorkbook.Path & "\"

  Set WbkDest = Workbooks.Add    ' Create new empty workbook

  RowWbksCrnt = 2
  WbkDestName = WshtWbks.Cells(RowWbksCrnt, 1).Value

  Do While True  ' Loop until find blank line in worksheet WorkBooks

    ' Get name of next source workbook
    With WshtWbks
      WbkSrcName = .Cells(RowWbksCrnt, 2).Value
      If WbkSrcName = "" Then Exit Do
      RowWbksCrnt = RowWbksCrnt + 1
    End With

    Debug.Print WbkSrcName;

    ' Open current source workbook
    Set WbkSrc = Workbooks.Open(Path & WbkSrcName, False, False)

    ' Copy worksheets "Sheet1" to "SheetN" from current
    ' source workbook to destination workbook
    NumShtCrnt = 1
    Do While True  '  Loop until SheetN does not exist
      If Not WshtExists(WbkSrc, "Sheet" & NumShtCrnt) Then
        ' No more worksheets
        Exit Do
      End If
      Debug.Print "  " & NumShtCrnt;
      With WbkSrc
        Set WshtSrc = .Worksheets("Sheet" & NumShtCrnt)
      End With
      ' Create destination worksheet if it does not exist
      With WbkDest
        If Not WshtExists(WbkDest, "Sheet" & NumShtCrnt) Then
          Set WshtDest = .Worksheets.Add
          With WshtDest
            .Name = "Sheet" & NumShtCrnt
            .Move After:=WbkDest.Worksheets("Sheet" & NumShtCrnt - 1)
          End With
        Else
          Set WshtDest = .Worksheets("Sheet" & NumShtCrnt)
        End If
      End With
      'Debug.Print "  " & "Sheet" & NumShtCrnt
      ' Find dimensions of source worksheet
      Call FindLastRowCol(WshtSrc, RowSrcLast, ColSrcLast)
      ' Find last row of destination worksheet; do not need last column
      Call FindLastRowCol(WshtDest, RowDestLast, ColDestLast)
      'Debug.Print "  Src " & RowSrcLast & " " & ColSrcLast
      'Debug.Print "  Dest " & RowDestLast & " " & ColDestLast
      With WshtSrc
        If RowDestLast = 0 Then
          ' First source worksheet to be copied to this destination sheet
          ' Include header rows
          Set RngSrc = .Range(.Cells(1, 1), .Cells(RowSrcLast, ColSrcLast))
          ' Copy column widths
          For ColCrnt = 1 To ColSrcLast
            WshtDest.Columns(ColCrnt).ColumnWidth = WshtSrc.Columns(ColCrnt).ColumnWidth
          Next
        Else
          ' Not first worksheet so exclude header rows
          Set RngSrc = .Range(.Cells(RowSrcDataFirst, 1), .Cells(RowSrcLast, ColSrcLast))
        End If
      End With
      RngSrc.Copy Destination:=WshtDest.Cells(RowDestLast + 1, 1)
      NumShtCrnt = NumShtCrnt + 1
    Loop  ' for every worksheet in current source workbook
    WbkSrc.Close SaveChanges:=False
    Debug.Print
  Loop  ' for every source workbook

  WbkDest.Close SaveChanges:=True, Filename:=Path & WbkDestName

  Application.ScreenUpdating = False

End Sub

运行宏“准备”以在工作表“工作簿”中创建一个列表，如下所示：

我的文件夹中有四个数据工作簿； 你有十九个。 这些工作簿按创建的顺序列出，这可能不是您在新工作簿中想要的顺序。 将此工作表修改为如下所示：

A 列中的名称是新工作簿的名称。 我已将 B 列中的名称序列更改为我希望的 output 序列。 因此“Data B.xlsx”中的数据将首先出现，然后是“Data D.xlsx”中的数据，依此类推。 如果数据的顺序无关紧要，请不要理会 B 列。

一旦工作表“工作簿”如您所愿，运行宏“合并”。 在宏运行时，立即 Window 中出现以下内容，以提供粗略的进度指示器：

Data B.xlsx  1  2  3
Data D.xlsx  1  2  3
Data A.xlsx  1  2  3
Data C.xlsx  1  2  3

每个工作簿我只有三个工作表。 该宏处理与它找到的一样多的工作表名称“Sheets1”到“SheetsN”。 因此，对您而言，工作表编号列表将达到 16 个。您将拥有 19 个工作簿名称。 在我的笔记本电脑上，每个源工作表只用了几分之一秒，因此整个合并过程只用了很少的时间。

检查新数据工作簿后，将宏工作簿移动到下一个文件夹并再次运行准备和合并。 对每个文件夹重复。

宏中的注释告诉您每个代码块在做什么，而不是每个语句在做什么。 如有必要，请回来提出问题。