指定数据汇总

APPLE123

1、各单位每年上报一个工作簿，每个工作簿有若干工作表，每个工作表格式基本一样。
2、每个工作簿名称以单位名称命名。
3、现因工作需要，需从每个工作簿中提取相应数据，模拟结果详见本表
       A列为序号、B列为单位名称........
       B列至G列数据从相应工作表提取，详见各列的说明
请老师帮帮忙，想用vba一键提取，谢谢！

明天会更好zj

未考虑错误

quqiyuan

参与一下，供参考。。。

APPLE123

quqiyuan 发表于 2024-6-15 10:47
参与一下，供参考。。。

感谢老师哦的帮助！再请教一下老师：
如果要在汇总的最后一行增加一行合计数，分别对C、D、E、F、G列数据进行计算合计，该如何修改代码？
谢谢！

APPLE123

明天会更好zj 发表于 2024-6-15 10:13
未考虑错误

感谢老师哦的帮助！再请教一下老师：
如果要在汇总的最后一行增加一行合计数，分别对C、D、E、F、G列数据进行计算合计，该如何修改代码？
谢谢！

quqiyuan

APPLE123 发表于 2024-6-15 13:11
感谢老师哦的帮助！再请教一下老师：
如果要在汇总的最后一行增加一行合计数，分别对C、D、E、F、G列数 ...

ykcbf1100

参与一下。。。
加上合计行。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.6.15
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     ReDim brr(1 To 1000, 1 To 8)
   
8.     For Each f In Fso.GetFolder(p).Files
   
9.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.             fn = Fso.GetBaseName(f)
    
11.             Set wb = Workbooks.Open(f, 0)
    
12.             m = m + 1
    
13.             brr(m, 1) = m
    
14.             With wb
    
15.                 brr(m, 2) = .Sheets("基本信息").[c5].Value
    
16.                 brr(m, 3) = .Sheets("基本信息").[c7].Value
    
17.                 brr(m, 4) = .Sheets("基本信息").[c14].Value
    
18.                 brr(m, 5) = .Sheets("同一品牌").[c3].Value
    
19.                 brr(m, 6) = .Sheets("服务资本市场").[c4].Value
    
20.                 brr(m, 7) = .Sheets("服务高质量发展").[c4].Value
    
21.             End With
    
22.             wb.Close False
    
23.         End If
    
24.     Next f
    
25.     With sh
    
26.         .UsedRange.Offset(2).Clear
    
27.         .[a3].Resize(m, 7) = brr
    
28.         .[a3].Resize(m + 1, 8).Borders.LineStyle = 1
    
29.         .Cells(m + 3, 1) = "合计": .Cells(m + 3, 1).Resize(1, 2).Merge
    
30.         For x = 1 To 5
    
31.             .Cells(m + 3, x + 2) = Application.Sum(.Cells(3, x + 2).Resize(m))
    
32.         Next
    
33.     End With
    
34.     Application.ScreenUpdating = True
    
35.     MsgBox "合并完毕!"
    
36. End Sub
    

复制代码

APPLE123

quqiyuan 发表于 2024-6-15 13:27

谢谢老师的帮助！

APPLE123

ykcbf1100 发表于 2024-6-15 20:55
参与一下。。。

谢谢老师，太好用了，谢谢！