求助：将多个工作簿中的信息合并到一个表格中！请帮忙指教！

yyfcu

有100多个类似“单位A”、“单位B”等这样的单位报表(工作簿)，现在要自动合并到另一个表里“单位信息合并”，请教如何实现？谢谢你！

1.png(93.25 KB, 下载次数: 2)

下载附件 保存到相册
2018-1-29 11:00 上传

2.png(85.21 KB, 下载次数: 2)

下载附件 保存到相册
2018-1-29 11:00 上传

3.png(106.45 KB, 下载次数: 2)

下载附件 保存到相册
2018-1-29 11:00 上传

4.png(109.5 KB, 下载次数: 2)

下载附件 保存到相册
2018-1-29 11:00 上传

abc123281

求解abc123.rar (80.7 KB, 下载次数: 56)

2018-2-12 10:32 上传

点击文件名下载附件

gta

1. Public Sub huizong()
   
2. Dim MyRow, Myrow1, MyCol, arr, wb, i%, brr, crr, unfile
   
3. X:  arr = Application.GetOpenFilename("表格文件,*.xls*", 1, "选取工作表", , True)
   
4.     If IsArray(arr) = False Then      '当打开文件多选为：True时，用IsArray判断是否选择文件，当多选为False时，用arr<>false进行判断
   
5.         unfile = MsgBox("您未选中任何文件！" & Chr(10) & "按“确认”重新加载文件，或按“取消”退出", 1, "载入文件提示")
   
6.         If unfile <> vbCancel Then
   
7.         GoTo X                         '"按“确认”重新加载文件
   
8.         Else: Exit Sub                 '"按“取消”退出
   
9.         End If
   
10.     Else
    
11.          With ThisWorkbook.Worksheets("在职三定人员")
    
12.              .Range("a7:q60000").ClearContents
    
13.              MyRow = .Cells(Rows.Count, "b").End(xlUp).Row
    
14.              MyCol = 17
    
15.          End With
    
16.          For Each wb In arr
    
17.             Application.ScreenUpdating = False
    
18.             If wb <> ThisWorkbook.FullName Then  '判断选择的工作表是否为汇总表，否则向下执行，如是则退出，进行下一循环
    
19.                     Workbooks.Open (wb)
    
20.                     Worksheets("在职三定人员").Activate
    
21.                     With ActiveSheet
    
22.                         Myrow1 = .Cells(Rows.Count, "b").End(xlUp).Row
    
23.                         brr = .Range("a7:p" & Myrow1)
    
24.                         crr = Mid(.[a1].Value, 1, 3)
    
25.                     End With
    
26.                     i = i + 1
    
27.                     With ThisWorkbook.Worksheets("在职三定人员")
    
28.                          .Cells(MyRow + 1, "a").Resize(Myrow1 - 6, 1) = crr
    
29.                          .Cells(MyRow + 1, "b").Resize(Myrow1 - 6, MyCol - 1) = brr
    
30.                     End With
    
31.                     Set brr = Nothing
    
32.                     ActiveWorkbook.Close (False)
    
33.              End If
    
34.              MyRow = MyRow + Myrow1 - 6
    
35.         Next
    
36.      End If
    
37.      Application.ScreenUpdating = True
    
38. End Sub

复制代码