用excel VBA怎么把多个工作簿里的两列数据按名称对应复制到一个工作簿对应的列里

crossroadgirl

各位大师，我现在每个月要整理一张表， 这张表的列抬头是地区名，然后基础数据是从每个地区的年度表内取当月两列数，所以每个月都要复制黏贴无数次，想让哪位高人给写个VBA代码能实现的。以7月江苏分公司为例，我需要复制基础表中江苏分公司的N6:O131到总执行表中的B5：C130。数据太多，只放了部分分公司基础表做测试。急急急，在线等！谢谢大家了！

ppp710715

1. Sub test1()
   
2. Application.ScreenUpdating = False
   
3. Dim aw, t, k, br, s
   
4. Dim rg As Range, wk As Workbook
   
5. Set aw = ThisWorkbook
   
6.       '以下遍历文件，提取各公司数据
   
7.     p = aw.Path & ""
   
8.     f = Dir(p & "*.xls")
   
9.     Do While f <> ""
   
10.     If f <> ThisWorkbook.Name Then
    
11.         Set wk = GetObject(p & f)
    
12.         wk.Sheets(1).Activate
    
13.         t = InStr(wk.Name, ".")
    
14.         s = Left(wk.Name, t - 1)
    
15.         aw.Activate
    
16.         q = ActiveSheet.Name
    
17.         wk.Sheets(1).Activate
    
18.                 Set rg = wk.Sheets(1).[4:4].Find(q)
    
19.                 If Not rg Is Nothing Then
    
20.                    k = rg.Column
    
21.                    br = wk.Sheets(1).Range(Cells(6, k), Cells(131, k + 1)).Value
    
22.                    Else
    
23.                    MsgBox ActiveSheet.Name & "的数据未找到！"
    
24.                 End If
    
25.            aw.Activate
    
26.                 Set rg = ActiveSheet.[3:3].Find(s)
    
27.                 If Not rg Is Nothing Then
    
28.                    k = rg.Column
    
29.                    ActiveSheet.Range(Cells(5, k), Cells(130, k + 1)) = br
    
30.                    Else
    
31.                    MsgBox ActiveSheet.Name & "的数据未找到！"
    
32.                 End If
    
33.                    wk.Close False
    
34.     End If
    
35.         f = Dir
    
36.         Loop
    
37. Application.ScreenUpdating = True
    
38. MsgBox "数据汇总完毕！"
    
39. End Sub
    

复制代码

打开总执行表，按汇总按钮即可。其他表不用打开。
分公司月汇总.rar (465.3 KB, 下载次数: 5)

2017-10-10 10:20 上传

点击文件名下载附件