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

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

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

wengjl

Sub 汇总多个工作簿()
    ' https://club.excelhome.net/threa ... tml?_dsign=47bbe63f
    ' 2024-5-57
    ' 处理：取消汇总表上的合并单元格。
    Range("A2:J21").ClearContents
    Dim File As String
    Dim i&, j&
    Dim wb As Object
    'Application.ScreenUpdating = False
    File = Dir(ThisWorkbook.Path & "\*.xlsx")    '获取文件夹中第一张表的名称，*表示通配符
    i = 2
    Do 'While Len(File)     ' 按文件数量循环，第一次见识
       Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & File)   ' 打开文件
       ThisWorkbook.Sheets(1).Cells(i, 1).Value = i - 1
       ThisWorkbook.Sheets(1).Cells(i, 2).Value = wb.Sheets(1).Cells(6, 2).Value
       ThisWorkbook.Sheets(1).Cells(i, 3).Value = wb.Sheets(1).Cells(6, 5).Value
       ThisWorkbook.Sheets(1).Cells(i, 4).Value = wb.Sheets(1).Cells(7, 2).Value
       ThisWorkbook.Sheets(1).Cells(i, 5).Value = wb.Sheets(1).Cells(7, 5).Value
       ThisWorkbook.Sheets(1).Cells(i, 6).Value = wb.Sheets(1).Cells(8, 2).Value
       ThisWorkbook.Sheets(1).Cells(i, 7).Value = wb.Sheets(1).Cells(9, 2).Value
       ThisWorkbook.Sheets(1).Cells(i, 8).Value = wb.Sheets(1).Cells(10, 2).Value
       ThisWorkbook.Sheets(1).Cells(i, 9).Value = wb.Sheets(1).Cells(11, 2).Value
       ThisWorkbook.Sheets(1).Cells(i, 10).Value = wb.Sheets(1).Cells(12, 2).Value
       wb.Close False      ' 将打开的文件内容复制到当前工作簿后，不保存退出
       i = i + 1
       File = Dir()
       If Len(File) = 0 Then Exit Do  ' 经测试，这样也行
    Loop
    'Application.ScreenUpdating = False
End Sub