[已解决]求大师帮个忙，有附件。

jsdtxin

哪位大师能帮个忙
详见附件，

012汇总.rar (314.04 KB, 下载次数: 64)

2014-4-2 09:59 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-4-2 18:24

1. Sub Macro1()
   
2. Dim arr, brr, wb As Workbook, mypath$, wj$, i&
   
3. arr = [c3:ak4] '如果数据有规律，brr可循环赋值，否则逐条添加
   
4. ReDim brr(1 To 20000, 1 To UBound(arr, 2))
   
5. Application.ScreenUpdating = False
   
6. mypath = ThisWorkbook.Path & ""
   
7. wj = Dir(mypath & "*.xls*")
   
8. Do While wj <> ""
   
9.     If wj <> ThisWorkbook.Name Then
   
10.         Set wb = GetObject(mypath & wj)
    
11.         For i = 2 To wb.Sheets.Count - 2
    
12.             s = s + 1
    
13.             brr(s, 1) = wb.Name
    
14.             brr(s, 2) = wb.Sheets(i).Name
    
15.             With wb.Sheets(i)
    
16.                 brr(s, 3) = .[ar55]
    
17.                 brr(s, 4) = .[au2]
    
18.                 brr(s, 5) = .[au4]
    
19.                 '以下类推添加
    
20.             End With
    
21.         Next
    
22.         wb.Close 0
    
23.     End If
    
24. wj = Dir
    
25. Loop
    
26. Range("c5").Resize(s, UBound(brr, 2)) = brr
    
27. Application.ScreenUpdating = True
    
28. End Sub
    

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, wb As Workbook, i&
   
3. arr = Range("c4:al" & Cells(Rows.Count, 4).End(xlUp).Row)
   
4. Application.ScreenUpdating = False
   
5. For i = 2 To UBound(arr)
   
6.     If arr(i, 1) = "" Then arr(i, 1) = arr(i - 1, 1)
   
7.     Set wb = GetObject(ThisWorkbook.Path & "" & Replace(arr(i, 1), "工作簿", "") & ".xls") '.xls 03后缀名，根据版本修改
   
8.     With wb.Sheets("" & arr(i, 2))
   
9.         arr(i, 3) = .[ar55]
   
10.         arr(i, 4) = .[au2]
    
11.         arr(i, 5) = .[au4]
    
12.             '其他类推
    
13.     End With
    
14.     wb.Close
    
15. Next
    
16. Range("c4").Resize(UBound(arr), UBound(arr, 2)) = arr
    
17. Application.ScreenUpdating = True
    
18. End Sub
    

复制代码

dsmch

……………………

jsdtxin

dsmch 发表于 2014-4-2 13:06
……………………

希望工作簿名与其中的工作表名都能自动获取填入汇总表内。

jsdtxin

dsmch 发表于 2014-4-2 13:06
……………………

另外同一文件夹内工作簿是不断增加的，要求都能被自动汇总，另外工作簿名是任意的，可以是纯数字名，示例里的“工作簿”三字要处理下，要求能适应任意名字的工作簿。

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, wb As Workbook, mypath$, wj$, i&
   
3. arr = [c3:ak4] '如果数据有规律，brr可循环赋值，否则逐条添加
   
4. ReDim brr(1 To 20000, 1 To UBound(arr, 2))
   
5. Application.ScreenUpdating = False
   
6. mypath = ThisWorkbook.Path & ""
   
7. wj = Dir(mypath & "*.xls*")
   
8. Do While wj <> ""
   
9.     If wj <> ThisWorkbook.Name Then
   
10.         Set wb = GetObject(mypath & wj)
    
11.         For i = 2 To wb.Sheets.Count - 2
    
12.             s = s + 1
    
13.             brr(s, 1) = wb.Name
    
14.             brr(s, 2) = wb.Sheets(i).Name
    
15.             With wb.Sheets(i)
    
16.                 brr(s, 3) = .[ar55]
    
17.                 brr(s, 4) = .[au2]
    
18.                 brr(s, 5) = .[au4]
    
19.                 '以下类推添加
    
20.             End With
    
21.         Next
    
22.         wb.Close 0
    
23.     End If
    
24. wj = Dir
    
25. Loop
    
26. Range("c5").Resize(s, UBound(brr, 2)) = brr
    
27. Application.ScreenUpdating = True
    
28. End Sub
    

复制代码

dsmch

………………

蓝粆

dsmch 发表于 2014-4-2 18:25
………………

刷最佳好厉害~~虽然还看不懂代码