多工作簿汇总为统计表

巳蛇

请教各位老师：如何将一个文件夹下的多个工作簿中的sheet1中的指定内容汇总到“问题跟踪表”里的指定表头下？
进一步请教：如果可以手动选择文件夹和工作簿更好。

xiangbaoan

看描述，简单；没附件，枉然。

small_small

1. Sub huizong()
   
2.     Dim arr, n As Byte, i As Integer, wk
   
3.     arr = Application.GetOpenFilename(, , , , True)
   
4.     If IsArray(arr) = False Then Exit Sub
   
5.     i = 1
   
6.     For n = 1 To UBound(arr)
   
7.         i = i + 1
   
8.         Set wk = Workbooks.Open(arr(n))
   
9.         With ThisWorkbook.Sheets("Sheet1")
   
10.             .Cells(i, 1) = [f4]
    
11.             .Cells(i, 2) = [x4]
    
12.             .Cells(i, 3) = [f5]
    
13.             .Cells(i, 4) = [x5]
    
14.             .Cells(i, 5) = [ai5]
    
15.             .Cells(i, 6) = [f6]
    
16.             .Cells(i, 7) = [x6]
    
17.             .Cells(i, 8) = [ai6]
    
18.             .Cells(i, 9) = [f7]
    
19.             .Cells(i, 10) = [x7]
    
20.             .Cells(i, 11) = [ai7]
    
21. '            .Cells(i, 12) = [f8]
    
22.             .Cells(i, 12) = [ae8]
    
23.         End With
    
24.         wk.Close 0
    
25.         Set wk = Nothing
    
26.     Next n
    
27. End Sub
    

复制代码

Nonenever

试一下

Nonenever

'https://club.excelhome.net/forum.php?mod=viewthread&tid=1163112&ordertype=1
参考的整的

1. Option Explicit
   
2. 'https://club.excelhome.net/forum.php?mod=viewthread&tid=1163112&ordertype=1
   
3. Sub L()
   
4.     Dim Mypath$, Myname$, str$, sht As Worksheet, i%, arr, drow%, drow1%, j%
   
5.     On Error Resume Next
   
6.     sht = ThisWorkbook.Worksheets("sheet1")
   
7.     '    Mypath = ThisWorkbook.Path & ""
   
8.     '    Myname = Dir(Mypath & "*.xlsx")
   
9.     Dim Flist As Variant
   
10.     Flist = Application.GetOpenFilename("数据文件,*.xls;*.xlsx;*.csv", Title:="选择文件", Buttontext:="OK", MultiSelect:=True)
    
11.     If TypeName(Flist) = "Boolean" Then
    
12.         Exit Sub
    
13.     End If
    
14.     Application.ScreenUpdating = False
    
15.     ReDim arr(1 To 12)
    
16.     For i = LBound(Flist) To UBound(Flist)
    
17.         Myname = Flist(i)
    
18.         '    Do While Myname <> ""
    
19.         If Myname <> ThisWorkbook.Name Then
    
20.             With GetObject(Mypath & Myname)
    
21.                 With .Sheets("试验问题反馈样表")
    
22.                     If .Range("A4") = "提出单位" Then
    
23.                         arr(1) = .Range("F4").Value
    
24.                         arr(2) = .Range("X4").Value
    
25.                         For j = 1 To 3
    
26.                             arr(2 + 3 * (j - 1) + 1) = .Cells(4 + j, "F").Value
    
27.                             arr(3 + 3 * (j - 1) + 1) = .Cells(4 + j, "X").Value
    
28.                             arr(4 + 3 * (j - 1) + 1) = .Cells(4 + j, "AI").Value
    
29.                         Next j
    
30.                         arr(12) = .Range("AE8").Value
    
31.                     End If
    
32.                 End With
    
33.                 .Close False
    
34.             End With
    
35.         End If
    
36.         With ThisWorkbook.Worksheets("sheet1")
    
37.             drow1 = .[a65526].End(3).Row
    
38.             .Cells(drow1 + 1, 1).Resize(1, 12) = arr
    
39.         End With
    
40.         Myname = Dir
    
41.         '    Loop
    
42.     Next i
    
43.     Application.ScreenUpdating = True
    
44. End Sub
    

复制代码

巳蛇

Nonenever 发表于 2021-10-25 22:26
'https://club.excelhome.net/forum.php?mod=viewthread&tid=1163112&ordertype=1
参考的整的

非常谢谢，完全适用！