[已解决]求一个多工作簿的取数宏

wanghq0310

求一个多工作簿取数宏，具体要求见附件汇总表，麻烦告知如何修改宏做后面的取数
求助.zip (14.02 KB, 下载次数: 14)

2014-9-25 14:37 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2014-9-29 10:54

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim filename, wb As Workbook, Sht As Worksheet, Sh As Worksheet, xRng As Range
   
4.     filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim arr(1 To 1000, 1 To 4)
   
6.     Set Sh = Sheet1
   
7.     Do While filename <> ""
   
8.         If filename <> ThisWorkbook.Name Then
   
9.             n = n + 1
   
10.             fn = ThisWorkbook.Path & "" & filename
    
11.             Set wb = Workbooks.Open(fn)
    
12.             Set Sht = wb.Worksheets("事（总表）")
    
13.             If n = 1 Then
    
14.                 Sh.[c1].Resize(1, 67).Value = Application.Transpose(Sht.[c7:c73])
    
15.                 Sh.Cells(1, 70).Resize(1, 68) = Application.Transpose(Sht.[L6:L73])
    
16.             End If
    
17.             r = Sh.[a65536].End(3).Row + 1
    
18.             Sh.Cells(r, 1) = Val(Mid(filename, 2))
    
19.             Sh.Cells(r, 2) = Trim(Mid(Sht.[a3], 6))
    
20.             Sh.Cells(r, 3).Resize(1, 67).Value = Application.Transpose(Sht.[g7:g73])
    
21.             Sh.Cells(r, 70).Resize(1, 68) = Application.Transpose(Sht.[p6:p73])
    
22.             wb.Close False
    
23.         End If
    
24.         filename = Dir
    
25.     Loop
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码

跳转到最佳答案楼层

grf1973

没见你代码在哪里，重新编了一个。

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim filename, wb As Workbook, Sht As Worksheet, Sh As Worksheet, xRng As Range
   
4.     filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim arr(1 To 1000, 1 To 4)
   
6.     Set Sh = Sheet1
   
7.     Do While filename <> ""
   
8.         If filename <> ThisWorkbook.Name Then
   
9.             n = n + 1
   
10.             fn = ThisWorkbook.Path & "" & filename
    
11.             Set wb = Workbooks.Open(fn)
    
12.             Set Sht = wb.Worksheets(1)
    
13.             arr(n, 1) = Val(Mid(filename, 2))
    
14.             For j = 2 To 4
    
15.                 x = Sh.Cells(1, j)
    
16.                 Set xRng = Sht.Range("d:d").Find(x, lookat:=xlPart)
    
17.                 If Not xRng Is Nothing Then arr(n, j) = xRng.Offset(0, 1)
    
18.             Next
    
19.             wb.Close False
    
20.         End If
    
21.         filename = Dir
    
22.     Loop
    
23.     Sh.Range("a2:d1000").ClearContents
    
24.     Sh.[a2].Resize(n, 4) = arr
    
25.     Application.ScreenUpdating = True
    
26. End Sub
    

复制代码

grf1973

请看附件。

wanghq0310

grf1973 发表于 2014-9-26 09:51
请看附件。

大神这个附件可以了，但是我要怎么添加更多的单元格呢，后面一个支出表有50几个数要取，可否教我一下

wanghq0310

grf1973 发表于 2014-9-26 09:51
请看附件。

我附件放了个完整的工作簿，工作表比较全，我自己做了一个简单的汇总，但是我不知道怎么改成对一个单元格的取数，他是对每个工作表的单元格取的，麻烦帮忙修改下。
如果方便的话你前面帮我做的那个当然更好一下子全出来的，样张那样的工作簿要100多个，全部要按样张的格式汇总
再次感谢了{:2812:} 试验品.rar (19.65 KB, 下载次数: 7)

2014-9-27 10:58 上传

点击文件名下载附件

grf1973

你要讲清楚汇总表里的各项分别从各工作簿的哪个工作表，哪个单元格而来，你的附件看不清楚。

wanghq0310

grf1973 发表于 2014-9-28 09:20
你要讲清楚汇总表里的各项分别从各工作簿的哪个工作表，哪个单元格而来，你的附件看不清楚。

我想了一下，直接把报表中的“事（总表）”每一个科目导出来做横向汇总，我把不要的再删就可以了
另外就是汇总时单位格取“事（总表）”的A3单元格，编号按文件名“【1】”第一个数字取，再次麻烦了

求助.rar (59.2 KB, 下载次数: 5)

2014-9-28 22:20 上传

点击文件名下载附件

grf1973

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim filename, wb As Workbook, Sht As Worksheet, Sh As Worksheet, xRng As Range
   
4.     filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Dim arr(1 To 1000, 1 To 4)
   
6.     Set Sh = Sheet1
   
7.     Do While filename <> ""
   
8.         If filename <> ThisWorkbook.Name Then
   
9.             n = n + 1
   
10.             fn = ThisWorkbook.Path & "" & filename
    
11.             Set wb = Workbooks.Open(fn)
    
12.             Set Sht = wb.Worksheets("事（总表）")
    
13.             If n = 1 Then
    
14.                 Sh.[c1].Resize(1, 67).Value = Application.Transpose(Sht.[c7:c73])
    
15.                 Sh.Cells(1, 70).Resize(1, 68) = Application.Transpose(Sht.[L6:L73])
    
16.             End If
    
17.             r = Sh.[a65536].End(3).Row + 1
    
18.             Sh.Cells(r, 1) = Val(Mid(filename, 2))
    
19.             Sh.Cells(r, 2) = Trim(Mid(Sht.[a3], 6))
    
20.             Sh.Cells(r, 3).Resize(1, 67).Value = Application.Transpose(Sht.[g7:g73])
    
21.             Sh.Cells(r, 70).Resize(1, 68) = Application.Transpose(Sht.[p6:p73])
    
22.             wb.Close False
    
23.         End If
    
24.         filename = Dir
    
25.     Loop
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码

grf1973

请看附件。

wanghq0310

grf1973 发表于 2014-9-29 10:55
请看附件。

可以了，万分感谢，省了好多事啊，如果我要取其他表的是不是只要把宏里面的工作表名字一改就可以了？