合并Excel文件

具体方法的执行还需要去看教程,这里就不说了。我只是记录一下不同的代码方面我自己查看使用。

主要分为三个部分:

  • 合并多个文件到一个 sheet 里
  • 合并多个文件到多个 sheets 里
  • 合并同一个文件里的多个 sheets

1. 合并多个文件到一个 sheet 里

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
Sub 合并当前目录下所有工作簿的全部工作表()
    Dim MyPath, MyName, AWbName
    Dim Wb As Workbook, WbN As String
    Dim G As Long
    Dim Num As Long
    Dim BOX As String
    Application.ScreenUpdating = False
    MyPath = ActiveWorkbook.Path
    MyName = Dir(MyPath & "" & "*.xls")
    AWbName = ActiveWorkbook.Name
    Num = 0
    Do While MyName <> ""
    If MyName <> AWbName Then
        Set Wb = Workbooks.Open(MyPath & "" & MyName)
        Num = Num + 1
        With Workbooks(1).ActiveSheet
        .Cells(.Range("B65536").End(xlUp).Row + 2, 1) = Left(MyName, Len(MyName) - 4)
        For G = 1 To Sheets.Count
        Wb.Sheets(G).UsedRange.Copy .Cells(.Range("B65536").End(xlUp).Row + 1, 1)
        Next
        WbN = WbN & Chr(13) & Wb.Name
        Wb.Close False
        End With
    End If
   
    MyName = Dir
    Loop
    Range("B1").Select
    Application.ScreenUpdating = True
    MsgBox "共合并了" & Num & "个工作薄下的全部工作表。如下:" & Chr(13) & WbN, vbInformation, "提示"
End Sub

2. 合并多个文件到多个 sheets 里

注:此代码的应用条件是所有文件需要在同一个文件夹内。该代码会获取文件的命名,自动填充到对应的sheet里。由于Excel的sheet命名不支持大于31个字符,所以事先需要检查文件名长度是否复合要求。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
Sub combo()
   
    Dim Wk As Workbook, Sht As Worksheet, n As Integer, MyPath, MyName
    Application.ScreenUpdating = False
    Application.EnableEvents = False
   
    n = 1
    MyPath = ThisWorkbook.Path & ""  '指定路径
    MyName = Dir(MyPath & "" & "*.xls") '
寻找第一项
   
    Do While MyName <> ""   '开始循环
    If MyName <> ThisWorkbook.Name Then
        Set Wk = Workbooks.Open(MyPath & "" & MyName)
        Wk.Sheets(1).Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) '
此处只插个第一个sheet
        ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Mid(MyName, 1, Len(MyName) - 4) '重新命名sheet
        '
For Each Sht In Wk.Sheets '多个sheet
        '
Sht.Name = Format(n, "000″)
        'n = n + 1
        'Next
        Wk.Close False
    End If
    MyName = Dir    '查找下一个
    Loop
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

3. 合并同一个文件里的多个 sheets

1
2
3
4
5
6
7
8
9
10
11
12
Sub UnionSheets()
    Application.ScreenUpdating = False
    For i = 1 To Sheets.Count
       If Sheets(i).Name <> ActiveSheet.Name Then
           X = Range("A65536").End(xlUp).Row + 1   '获取当前sheet中已有的行数,从+1行开始
           Sheets(i).UsedRange.Copy Cells(X, 1)    '
往当前sheet中的Cells(X, 1)开始复制数据
       End If
    Next
    Range("A1").Select '选中第一个单元格(返回到顶部)
    Application.ScreenUpdating = True
    MsgBox "合并完毕!", vbInformation, "提示"
End Sub
Leave a Reply