[已解决]请教高手做一个不同工作表的汇总问题？

hnnylf

请教高手，我有一个文件夹中有很多工作表，我需要不打开工作表时，把每个人的数据做一个汇总，我不会vba，请教帮忙做一下，谢谢！

最佳答案

月排行榜 / 总排行榜

E-H-P

2014-7-10 09:19

1. 威马.rar (27.9 KB, 下载次数: 5)
   2014-7-10 09:21 上传

   点击文件名下载附件 Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim the_path As String
   
3. Dim the_name As String
   
4. Dim arr(0 To 7, 0)
   
5. '客户申请贷款额  主车险  挂车险  交强险  车辆首付款  调查资料费  GPS 续保保证金
   
6. '[b6]    [d10]   [d11]   [d12]   [g10]   [g15]   [g17]   [g18]
   
7. Application.ScreenUpdating = False
   
8. If Target.Column = 1 And Target.Row > 1 Then
   
9. the_path = ThisWorkbook.Path & ""
   
10. the_name = "威马分期-" & Target.Value
    
11.     If Dir(the_path & the_name & ".xls") <> "" Then
    
12.         With GetObject(the_path & the_name & ".xls")
    
13.                 arr(0, 0) = .Sheets(1).[b6]
    
14.                 arr(1, 0) = .Sheets(1).[d10]
    
15.                 arr(2, 0) = .Sheets(1).[d11]
    
16.                 arr(3, 0) = .Sheets(1).[d12]
    
17.                 arr(4, 0) = .Sheets(1).[g10]
    
18.                 arr(5, 0) = .Sheets(1).[g15]
    
19.                 arr(6, 0) = .Sheets(1).[g17]
    
20.                 arr(7, 0) = .Sheets(1).[g18]
    
21.         .Close True
    
22.         End With
    
23.     End If
    
24. Target.Offset(0, 1).Resize(1, 8) = Application.Transpose(arr)
    
25. End If
    
26. Application.ScreenUpdating = True
    
27. 
    
28. Exit Sub
    
29. End Sub

复制代码

跳转到最佳答案楼层

E-H-P

1. 威马.rar (27.9 KB, 下载次数: 5)
   2014-7-10 09:21 上传

   点击文件名下载附件 Private Sub Worksheet_Change(ByVal Target As Range)
   
2. Dim the_path As String
   
3. Dim the_name As String
   
4. Dim arr(0 To 7, 0)
   
5. '客户申请贷款额  主车险  挂车险  交强险  车辆首付款  调查资料费  GPS 续保保证金
   
6. '[b6]    [d10]   [d11]   [d12]   [g10]   [g15]   [g17]   [g18]
   
7. Application.ScreenUpdating = False
   
8. If Target.Column = 1 And Target.Row > 1 Then
   
9. the_path = ThisWorkbook.Path & ""
   
10. the_name = "威马分期-" & Target.Value
    
11.     If Dir(the_path & the_name & ".xls") <> "" Then
    
12.         With GetObject(the_path & the_name & ".xls")
    
13.                 arr(0, 0) = .Sheets(1).[b6]
    
14.                 arr(1, 0) = .Sheets(1).[d10]
    
15.                 arr(2, 0) = .Sheets(1).[d11]
    
16.                 arr(3, 0) = .Sheets(1).[d12]
    
17.                 arr(4, 0) = .Sheets(1).[g10]
    
18.                 arr(5, 0) = .Sheets(1).[g15]
    
19.                 arr(6, 0) = .Sheets(1).[g17]
    
20.                 arr(7, 0) = .Sheets(1).[g18]
    
21.         .Close True
    
22.         End With
    
23.     End If
    
24. Target.Offset(0, 1).Resize(1, 8) = Application.Transpose(arr)
    
25. End If
    
26. Application.ScreenUpdating = True
    
27. 
    
28. Exit Sub
    
29. End Sub

复制代码

hnnylf

感谢2楼朋友，这样做很好，以后要好好学习vba啊