用VBA抽取一个文件夹中所有Excel并合并成一个Sheet

Mengkelyu

应群里要求，给大家提供相关代码。可以把文件夹中所有Excel文件里面所有Tab的数据（不包含格式）合并成一个Excel文件。

注意，这里我们支持xlsx, xls, xlsb, xlsm；但如果是xlsb和xlsm，最好把这个文件夹设置成信任路径"Trusted Location"，否则会弹出是否启用宏的警告。

话不多说，来上代码

Sub Copyfrom_all_excel_files_in_folder()

Dim FoldPath As String
Dim DialogBox As FileDialog
Dim FileOpen As String
Dim cntrows As Long
Dim rng As Variant
On Error Resume Next

'这里会弹出一个对话框让我们选择文件夹'

Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
If DialogBox.Show = -1 Then
FoldPath = DialogBox.SelectedItems(1)
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False
If FoldPath = "" Then Exit Sub
FileOpen = Dir(FoldPath & "\*.xls*")
Do While FileOpen <> ""

'打开excel'
Set wbResults = Workbooks.Open(FoldPath & "\" & FileOpen, UpdateLinks:=0, ReadOnly:=True)
      
      For Each st In wbResults.Worksheets '循坏过每个Sheet'
        rng = st.UsedRange.Value
        '把rng粘贴到我们output这个worksheet
        ThisWorkbook.Worksheets("Output").Range("A1").Offset(cntrows, 0).Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
        cntrows = cntrows + UBound(rng, 1)
    Next
wbResults.Close
FileOpen = Dir
Loop


Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Mengkelyu

Copy_to_excel.zip
示例附上

Mengkelyu

Enhancement 1: 如何指定要复制的工作表名称和输出的位置

例如我们的每个Excel里面有三个工作表，我们要输出到对应本工作薄里面的三个工作表中；
对应关系如下：

同时，需要保证Tab Name和To Tab的输入是可变的，允许增加对应关系，允许减少对应关系。

Mengkelyu

第一步我们要把这个读入工作表名和读出工作表名的map读入宏。可以这么写。这里是选择了Parameters这个工作表里面"A1"按住Ctrl+A选中的区域，并通过Offset向下移一格，然后用resize减少一行；这样可以去掉读入的表标题。

Dim mapping As Variant
With ThisWorkbook.Worksheets("Parameters").Range("A1").CurrentRegion
    mapping = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
End With

那么我们就把下面这个表储存到mapping这个变量里面啦

然后我们定义一个变量用来储存每个读出的数据总数，这里我们需要三组变量；因此这应该是一个有三个数字的数组。

Dim cntrows As Variant
ReDim cntrows(UBound(mapping, 1))

最后一步就是循环每个工作薄里面的每个工作表，如果这个工作表名能和Map里面的第一列任意一个匹配，那么它就会被输出到Map里面第二列对应的工作表内。

For Each st In wbResults.Worksheets
        For i = 1 To UBound(mapping, 1)
              If st.Name = mapping(i, 1) Then
              rng = st.UsedRange.Value
              ThisWorkbook.Worksheets(mapping(i, 2)).Range("A1").Offset(cntrows(i), 0).Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
              cntrows(i) = cntrows(i) + UBound(rng, 1)
              End If
        Next i

完整代码

Sub Copyfrom_all_excel_files_in_folder()

Dim FoldPath As String
Dim DialogBox As FileDialog
Dim FileOpen As String

Dim rng As Variant
On Error Resume Next
Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
If DialogBox.Show = -1 Then
FoldPath = DialogBox.SelectedItems(1)
End If

Application.ScreenUpdating = False
Application.DisplayAlerts = False

'read the mapping to the macro

Dim mapping As Variant
With ThisWorkbook.Worksheets("Parameters").Range("A1").CurrentRegion
    mapping = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count).Value
End With

Dim cntrows As Variant
ReDim cntrows(UBound(mapping, 1))

Dim i As Integer

' If the output sheet does not exist create it
For i = 1 To UBound(mapping, 2)
    If WorksheetExists(mapping(i, 2)) = False Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = mapping(i, 2)
Next i


 On Error GoTo 0
If FoldPath = "" Then Exit Sub
FileOpen = Dir(FoldPath & "\*.xls*")
Do While FileOpen <> ""
Set wbResults = Workbooks.Open(FoldPath & "\" & FileOpen, UpdateLinks:=0, ReadOnly:=True)
      
      For Each st In wbResults.Worksheets
        For i = 1 To UBound(mapping, 1)
              If st.Name = mapping(i, 1) Then
              rng = st.UsedRange.Value
              ThisWorkbook.Worksheets(mapping(i, 2)).Range("A1").Offset(cntrows(i), 0).Resize(UBound(rng, 1), UBound(rng, 2)).Value = rng
              cntrows(i) = cntrows(i) + UBound(rng, 1)
              End If
        Next i
    Next
wbResults.Close
FileOpen = Dir
Loop


Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub
Function WorksheetExists(ByVal shtName As String, Optional ByVal wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

Copy_to_excel - V2.zip