[已解决]多个表提取相同Sheet名，相同位置单元格数据汇总到同一个Sheet

jk0932

如附件所示：现举例如附件，
有若干个workbook名字为A表～E表（实际中可能变化），需要提取每个表中Sheet名字为XX的E8～F9,4个单元格的数据放入《结果》表中，结果示范如下：
标黄的列是单元格位置：表名的行填入提取的workbook名称，提取结果填入对应的位置
[tr]  [td=72]表名[/td]  [td=72]A表[/td]  [td=72]B表[/td]  [td=72]C表[/td]  [td=72]D表[/td]  [td=72]E表[/td] [/tr]
[tr]  [td]E8[/td]  [td]A1[/td]  [td]A1[/td]  [td]A1[/td]  [td]A1[/td]  [td]A1[/td] [/tr]
[tr]  [td]E9[/td]  [td]A3[/td]  [td]A3[/td]  [td]A3[/td]  [td]A3[/td]  [td]A3[/td] [/tr]
[tr]  [td]F8[/td]  [td]A2[/td]  [td]A2[/td]  [td]A2[/td]  [td]A2[/td]  [td]A2[/td] [/tr]
[tr]  [td]F9[/td]  [td]A4[/td]  [td]A4[/td]  [td]A4[/td]  [td]A4[/td]  [td]A4[/td] [/tr]

最佳答案

月排行榜 / 总排行榜

lygkkk

2017-2-18 11:22

写的丑了点 N久没写了 将就下吧

1. Sub test()
   
2.     Dim mso As Object
   
3.     Dim fileName As String
   
4.     Dim folderName As String
   
5.     Dim wb As String
   
6.     Dim arr
   
7.     Dim cloumn As Integer
   
8.     Dim row As Integer
   
9.    
   
10.     wb = ThisWorkbook.Name
    
11.     Set mso = Application.FileDialog(msoFileDialogFolderPicker)
    
12.    
    
13.     If mso.Show = -1 Then
    
14.           '  MsgBox "您选择的文件夹是：" & mso.SelectedItems(1), vbOKOnly + vbInformation, "智能Excel"
    
15.     Else
    
16.         Exit Sub
    
17.     End If
    
18.    
    
19.     folderName = mso.SelectedItems(1)
    
20.     fileName = Dir(folderName & "/*.xlsx")
    
21.    
    
22.     Do While fileName <> ""
    
23.         Workbooks.Open (folderName & "/" & fileName)
    
24.         arr = Workbooks(fileName).Sheets("xx").Range("e8:f9")
    
25.         Column = Workbooks(wb).Sheets("xx").Range("xfd1").End(xlToLeft).Column + 1
    
26.         Workbooks(fileName).Sheets("xx").Range("e8:e9").Copy Destination:=Workbooks(wb).Sheets("xx").Cells(2, Column)
    
27.         Workbooks(fileName).Sheets("xx").Range("f8:f9").Copy Destination:=Workbooks(wb).Sheets("xx").Cells(4, Column)
    
28.         Workbooks(wb).Sheets("xx").Cells(1, Column) = fileName
    
29.         fileName = Dir
    
30.     Loop
    
31. 
    
32. End Sub

复制代码

跳转到最佳答案楼层

lygkkk

写的丑了点 N久没写了 将就下吧

1. Sub test()
   
2.     Dim mso As Object
   
3.     Dim fileName As String
   
4.     Dim folderName As String
   
5.     Dim wb As String
   
6.     Dim arr
   
7.     Dim cloumn As Integer
   
8.     Dim row As Integer
   
9.    
   
10.     wb = ThisWorkbook.Name
    
11.     Set mso = Application.FileDialog(msoFileDialogFolderPicker)
    
12.    
    
13.     If mso.Show = -1 Then
    
14.           '  MsgBox "您选择的文件夹是：" & mso.SelectedItems(1), vbOKOnly + vbInformation, "智能Excel"
    
15.     Else
    
16.         Exit Sub
    
17.     End If
    
18.    
    
19.     folderName = mso.SelectedItems(1)
    
20.     fileName = Dir(folderName & "/*.xlsx")
    
21.    
    
22.     Do While fileName <> ""
    
23.         Workbooks.Open (folderName & "/" & fileName)
    
24.         arr = Workbooks(fileName).Sheets("xx").Range("e8:f9")
    
25.         Column = Workbooks(wb).Sheets("xx").Range("xfd1").End(xlToLeft).Column + 1
    
26.         Workbooks(fileName).Sheets("xx").Range("e8:e9").Copy Destination:=Workbooks(wb).Sheets("xx").Cells(2, Column)
    
27.         Workbooks(fileName).Sheets("xx").Range("f8:f9").Copy Destination:=Workbooks(wb).Sheets("xx").Cells(4, Column)
    
28.         Workbooks(wb).Sheets("xx").Cells(1, Column) = fileName
    
29.         fileName = Dir
    
30.     Loop
    
31. 
    
32. End Sub

复制代码