【VBA案例012】合并工作簿

归档779

审技265 程技242 投技146 财技57 税技47 法技11 食技7 书技4

301 字

2 分钟

【VBA案例012】合并工作簿

2023-10-23

程技

VBA

浏览量加载中...

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

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

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

自定义函数：

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

方法一：复制粘贴#

1
Sub 复制粘贴()
2

3
    Dim i, j, k
4
    Dim fileAr
5

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

8
    Application.ScreenUpdating = False
9
    For i = 1 To UBound(fileAr)
10
        With Workbooks.Open(ThisWorkbook.Path & "\文件夹\" & fileAr(i))
11
            With .Sheets(1)
12
                .Range("a2:e" & .[a65536].End(3).Row).Copy Sheet1.Range("a" & Sheet1.[a65536].End(3).Row + 1)
13
            End With
14
            .Close False
15
        End With
16
    Next i
17
    Application.ScreenUpdating = True
18

19
End Sub

方法二：数组#

1
Sub 数组()
2

3
    Dim i, j, k
4
    Dim fileAr
5

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

8
    Dim tmp
9
    Application.ScreenUpdating = False
10
    For i = 1 To UBound(fileAr)
11
        With Workbooks.Open(ThisWorkbook.Path & "\文件夹\" & fileAr(i))
12
            With .Sheets(1)
13
                tmp = .Range("a2:e" & .[a65536].End(3).Row)
14
                Sheet1.Range("a" & Sheet1.[a65536].End(3).Row + 1).Resize(UBound(tmp), UBound(tmp, 2)) = tmp
15
            End With
16
            .Close False
17
        End With
18
    Next i
19
    Application.ScreenUpdating = True
20

21
End Sub