[已解决]提取几个表中相同位置的数据汇总

jk0932

有若干个表，每个工作簿都有一个Sheet名称为XX，现在需要提取各个工作簿中Sheet名为XX的E8~F9 4 个单元格的数据，放入到汇总表；最终汇总到成4行数据

最佳答案很厉害

最佳答案

月排行榜 / 总排行榜

grf1973

2017-2-17 11:11

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet, sh As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Set sh = ActiveSheet
   
6.     j = 1
   
7.     Do While Filename <> ""
   
8.         If Filename <> ThisWorkbook.Name Then
   
9.             fn = ThisWorkbook.Path & "" & Filename
   
10.             Set wb = Workbooks.Open(fn)
    
11.             Set Sht = wb.Worksheets("XX")
    
12.             j = j + 1: sh.Cells(1, j) = Split(Filename, ".")(0)
    
13.             For i = 2 To 5
    
14.                 ad = sh.Cells(i, 1)
    
15.                 sh.Cells(i, j) = Sht.Range(ad)
    
16.             Next
    
17.             wb.Close False
    
18.         End If
    
19.         Filename = Dir
    
20.     Loop
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 导入文件()
   
2.     Application.ScreenUpdating = False
   
3.     Dim Filename, wb As Workbook, Sht As Worksheet, sh As Worksheet
   
4.     Filename = Dir(ThisWorkbook.Path & "\*.xls")
   
5.     Set sh = ActiveSheet
   
6.     j = 1
   
7.     Do While Filename <> ""
   
8.         If Filename <> ThisWorkbook.Name Then
   
9.             fn = ThisWorkbook.Path & "" & Filename
   
10.             Set wb = Workbooks.Open(fn)
    
11.             Set Sht = wb.Worksheets("XX")
    
12.             j = j + 1: sh.Cells(1, j) = Split(Filename, ".")(0)
    
13.             For i = 2 To 5
    
14.                 ad = sh.Cells(i, 1)
    
15.                 sh.Cells(i, j) = Sht.Range(ad)
    
16.             Next
    
17.             wb.Close False
    
18.         End If
    
19.         Filename = Dir
    
20.     Loop
    
21.     Application.ScreenUpdating = True
    
22. End Sub

复制代码