【VBA案例012】合并工作簿

大家好！这次分享的是非常经典的案例：合并工作簿。

相信大家已经很熟悉这个问题了，就是把多个工作簿里的工作表合并到同一个sheet里。

这次同样分享两个方法，以下是VBA代码。详细解析请看文末的视频。

自定义函数：

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Private Function filelist(folderspec, Optional pstr = "*.txt")
    On Error GoTo errline
    Dim fs, f, f1, fc, i, farr
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(folderspec)
    Set fc = f.Files
    ReDim farr(1 To fc.Count)
    For Each f1 In fc
        If f1.Name Like pstr And Not f1.Name Like "*~$*" Then
            i = i + 1
            farr(i) = f1.Name
        End If
    Next
    ReDim Preserve farr(1 To i)
    filelist = farr
errline:
End Function

方法一：复制粘贴

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub 复制粘贴()

    Dim i, j, k
    Dim fileAr

    fileAr = filelist(ThisWorkbook.Path & "\文件夹\", "*.xlsx")

    Application.ScreenUpdating = False
    For i = 1 To UBound(fileAr)
        With Workbooks.Open(ThisWorkbook.Path & "\文件夹\" & fileAr(i))
            With .Sheets(1)
                .Range("a2:e" & .[a65536].End(3).Row).Copy Sheet1.Range("a" & Sheet1.[a65536].End(3).Row + 1)
            End With
            .Close False
        End With
    Next i
    Application.ScreenUpdating = True

End Sub

方法二：数组

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub 数组()

    Dim i, j, k
    Dim fileAr

    fileAr = filelist(ThisWorkbook.Path & "\文件夹\", "*.xlsx")

    Dim tmp
    Application.ScreenUpdating = False
    For i = 1 To UBound(fileAr)
        With Workbooks.Open(ThisWorkbook.Path & "\文件夹\" & fileAr(i))
            With .Sheets(1)
                tmp = .Range("a2:e" & .[a65536].End(3).Row)
                Sheet1.Range("a" & Sheet1.[a65536].End(3).Row + 1).Resize(UBound(tmp), UBound(tmp, 2)) = tmp
            End With
            .Close False
        End With
    Next i
    Application.ScreenUpdating = True

End Sub

原始链接