提取多个工作簿（有合并单元格）信息到同一个工作表

bzciqql

我用VBA做了一个小程序，想把多个个人的出差报告中指定单元格信息提取汇总到一个汇总表里，程序运行没有报错，但是信息却没有提取汇总出来，请各位专家看看是怎么回事,VBA程序在后缀为xlsm的汇总表里进入vba界面即可查看。

注意：分表和汇总表都有合并单元格。

dambcer

1. Sub 汇总多个工作簿()
   
2.     Dim File As String
   
3.     Dim i&, j&
   
4.     Dim wb As Object
   
5.     Application.ScreenUpdating = False
   
6.     File = Dir(ThisWorkbook.Path & "\*.xlsx") '获取文件夹中第一张表的名称，*表示通配符
   
7.     i = 2
   
8.     Do While Len(File)
   
9.         Set wb = Workbooks.Open(ThisWorkbook.Path & "" & File) '打开文件
   
10.         '将打开的文件内容复制到当前工作簿
    
11.         wb.Sheets(1).Range("B6:C6").Copy Destination:=ThisWorkbook.Sheets(1).Range("B" & i & ":C" & i)
    
12.         wb.Sheets(1).Range("E6:G6").Copy Destination:=ThisWorkbook.Sheets(1).Range("D" & i & ":F" & i)
    
13.         wb.Sheets(1).Range("B7:C7").Copy Destination:=ThisWorkbook.Sheets(1).Range("G" & i & ":H" & i)
    
14.         wb.Sheets(1).Range("E7:G7").Copy Destination:=ThisWorkbook.Sheets(1).Range("I" & i & ":K" & i)
    
15.         wb.Sheets(1).Range("B8:G8").Copy Destination:=ThisWorkbook.Sheets(1).Range("L" & i & ":Q" & i)
    
16.         wb.Sheets(1).Range("B9:G9").Copy Destination:=ThisWorkbook.Sheets(1).Range("R" & i & ":W" & i)
    
17.         wb.Sheets(1).Range("B10:G10").Copy Destination:=ThisWorkbook.Sheets(1).Range("X" & i & ":AC" & i)
    
18.         wb.Sheets(1).Range("B11:G11").Copy Destination:=ThisWorkbook.Sheets(1).Range("AD" & i & ":AI" & i)
    
19.         wb.Sheets(1).Range("B12:G12").Copy Destination:=ThisWorkbook.Sheets(1).Range("AJ" & i & ":AO" & i)
    
20.         wb.Close False '不保存退出
    
21.         i = i + 1
    
22.         File = Dir()
    
23.     Loop
    
24.     Application.ScreenUpdating = False
    
25. End Sub

复制代码

zpy2

这种感觉可以在线表单收集

jjmysjg

好东西，一块学习，谢谢楼主！