如何合并多个EXCEL表格

胡国琛

日常工作中，经常会给不同单位发很多表头一样的表格，最后收上来以后，手动一个一个粘贴太费事费力，也安装了方方格子，但是不知道用那个功能比较合适，请大家支招。（源文件已经上传）

wh72988

用excel   插入  对象     由文件创建

abc3479

1. Sub 取数据()
   
2. Dim str As String
   
3. Dim wb As Workbook
   
4. Dim i, j As Integer   'i用来计算数据源的表有多少行  j用来计算汇总表目前有多少行数据，例如有10行，就从11行开始复制数据
   
5. Excel.Application.DisplayAlerts = False
   
6. Excel.Application.ScreenUpdating = False
   
7. 
   
8. 
   
9. str = Dir("D:\安装包\源文件\*.xls*")
   
10. 
    
11. For i = 1 To 100
    
12.     Set wb = Workbooks.Open("D:\安装包\源文件" & str)
    
13. '上面是壳子###################################################################
    
14.    
    
15.     i = wb.Sheets(1).Range("a65535").End(xlUp).Row
    
16.     j = ThisWorkbook.Sheets("数据").Range("a65535").End(xlUp).Row
    
17.    
    
18.     wb.Sheets(1).Range("a3:g" & i).Copy ThisWorkbook.Sheets("数据").Range("a" & j + 1)  '数据源的数据复制到汇总表里面
    
19.     'ThisWorkbook.Sheets("数据").Range("h" & j + 1).Resize(i - 1, 1) = Split(wb.Name, ".")(0)  '从汇总表复制数据那一行开始，用resize往下选i-1行，里面全写上城市名
    
20.    
    
21.    
    
22. '下面是壳子###################################################################
    
23.     wb.Close
    
24.     str = Dir
    
25.     If str = "" Then
    
26.         Exit For
    
27.     End If
    
28. Next
    
29. 
    
30. Excel.Application.DisplayAlerts = True
    
31. Excel.Application.ScreenUpdating = True
    
32. End Sub

复制代码

3190496160

Sub 合并工作簿()
Application.ScreenUpdating = False
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录：", 0, 0)   '选择文件夹对话框
If obmapp Is Nothing Then MsgBox "您没有选择文件夹！": End '如果选择了文件夹
fp = obmapp.Self.Path   '把选择的文件夹的路劲赋值给变量fp
Set ww = ThisWorkbook.Worksheets("汇总")
With ww
    ww.UsedRange.Clear
    f = Dir(fp & "\*.xls*")
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            m = m + 1
            Set wb = Workbooks.Open(fp & "\" & f, 0)
            With wb.Worksheets(1)
                r = .Cells(Rows.Count, 2).End(xlUp).Row
                rs = ww.Cells(Rows.Count, 2).End(xlUp).Row + 1
                If m = 1 Then
                    .Range("a2:d" & r).Copy ww.Cells(rs, 1)
                Else
                    .Range("a3:d" & r).Copy ww.Cells(rs, 1)
                End If
            End With
            wb.Close False
        End If
    f = Dir
    Loop
    rs = ww.Cells(Rows.Count, 2).End(xlUp).Row
    For i = 3 To rs
        .Cells(i, 1) = i - 2
    Next i
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

汇总.rar (23.76 KB, 下载次数: 8)

2024-5-11 10:43 上传

点击文件名下载附件

minchar

PQ来处文件夹，合并文件

沈默00

粘贴？是要汇总到一张表里吗？

abc3479

试用一下看看

3190496160

点击按钮，出现对话框，对话框中国选择需要汇总的文件所在的文件夹即可

沈默00