【VBA案例005】自动汇总表单

归档779

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

589 字

3 分钟

【VBA案例005】自动汇总表单

2023-10-23

程技

VBA

浏览量加载中...

大家好！书接上文。

有时候，我们需要处理多个工作簿，每个工作簿中包含一些特定的信息。为了将这些信息汇总到一个表中，我们可能需要手动打开每个工作簿，然后复制粘贴所需的数据。但这样做既费时又容易出错。

所以，使用VBA依然可以解决这个问题。极大地简化这一过程，让我们能够更专注于其他重要的工作。

举个例子，现在我们有100个工作簿。

需要从里边提取员工信息汇总到一个表里边。

猜猜看，用VBA处理这些需要多久？

下面是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
    Dim i, j, k
3
    Dim filePath As String, fileAr
4

5
    filePath = ThisWorkbook.Path & "\表单\"
6
    fileAr = filelist(filePath, "*.xlsx")
7

8
    Dim t As Double
9
    Dim wb As Workbook
10
    Application.ScreenUpdating = False
11

12
    t = Timer
13

14
    k = 1
15
    For i = 1 To UBound(fileAr)
16
        Set wb = Workbooks.Open(filePath & fileAr(i))
17
        With wb.Worksheets(1)
18
            k = k + 1
19
            For j = 1 To 5
20
                ThisWorkbook.Worksheets("Sheet1").Cells(k, j) = .Range("c" & j + 4)
21
            Next
22
        End With
23
        wb.Close False
24
    Next i
25
    Application.ScreenUpdating = True
26

27
    MsgBox Format(Timer - t, "0.000s")
28
End Sub

方法二：#

1
Sub 方法二数组()
2
    Dim i, j, k
3
    Dim filePath As String, fileAr
4
    Dim br(1 To 5000, 1 To 5)
5
    filePath = ThisWorkbook.Path & "\表单\"
6
    fileAr = filelist(filePath, "*.xlsx")
7

8
    Dim t As Double
9
    Dim wb As Workbook
10
    Application.ScreenUpdating = False
11

12
    t = Timer
13

14
    k = 0
15
    Dim tmp
16
    For i = 1 To UBound(fileAr)
17
        Set wb = Workbooks.Open(filePath & fileAr(i))
18

19
        With wb.Worksheets(1)
20
            tmp = .Range("c5:c9")
21
            k = k + 1
22
            For j = 1 To 5
23
                br(i, j) = tmp(j, 1)
24
            Next
25
        End With
26
        wb.Close False
27
    Next i
28
    ThisWorkbook.Worksheets(1).[a2].Resize(k, UBound(br, 2)) = br
29
    Application.ScreenUpdating = True
30

31
    MsgBox Format(Timer - t, "0.000s")
32
End Sub

方法三：#

1
Sub 方法三()
2
    Dim i, j, k
3
    Dim filePath As String, fileAr
4
    Dim br(1 To 5000, 1 To 5)
5
    filePath = ThisWorkbook.Path & "\表单\"
6
    fileAr = filelist(filePath, "*.xlsx")
7

8
    Dim t As Double
9
    Dim wb As Workbook
10
    Application.ScreenUpdating = False
11

12
    t = Timer
13

14
    k = 0
15
    Dim tmp
16
    For i = 1 To UBound(fileAr)
17
        k = k + 1
18
        For j = 1 To 5
19
            br(i, j) = Application.ExecuteExcel4Macro("'" & filePath & "[" & fileAr(i) & "]信息卡'!" & Range("c" & j + 4).Address(, , xlR1C1))
20
        Next
21
    Next i
22
    ThisWorkbook.Worksheets(1).[a2].Resize(k, UBound(br, 2)) = br
23
    Application.ScreenUpdating = True
24

25
    MsgBox Format(Timer - t, "0.000s")
26
End Sub