求助，多表汇总

ykcbf1100

菊子红了 发表于 2024-8-20 13:20
代码跑完是空白的，不知道问题出在哪里？

我这里是有数据的。

菊子红了

ykcbf1100 发表于 2024-8-19 18:47
问一下，汇总表中的B~N列数据是不是原来就有的？看了一下，O列后面的数据是要提取的。

如果只是提取O ...

”问一下，汇总表中的B~N列数据是不是原来就有的？“
汇总表中的B~N列数据也需要提取，
单元格[F454]并不是每个工作簿都有数据的。

ykcbf1100

菊子红了 发表于 2024-8-20 16:01
”问一下，汇总表中的B~N列数据是不是原来就有的？“
汇总表中的B~N列数据也需要提取，
单元格[F454]并 ...

按你这个需求，重新写了一个，比原来那个简单。

ykcbf1100

重新写一个。。。

1. Sub ykcbf()   '//2024.8.20
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
5.     b = Application.Transpose(sh.[p3:y3].Value)
   
6.     p = ThisWorkbook.Path & ""
   
7.     ReDim brr(1 To 10000, 1 To 100)
   
8.     For Each f In fso.GetFolder(p).Files
   
9.         If LCase$(f.Name) Like "*.xls*" Then
   
10.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.                 fn = fso.GetBaseName(f)
    
12.                 Set wb = Workbooks.Open(f, 0)
    
13.                 With wb.Sheets("Report")
    
14.                     r = .Cells(Rows.Count, "aw").End(3).Row
    
15.                     arr = .[av4].Resize(10, 13)
    
16.                     For i = 1 To UBound(arr)
    
17.                         If arr(i, 2) <> Empty Then
    
18.                             m = m + 1
    
19.                             For j = 1 To UBound(arr, 2)
    
20.                                 brr(m, j) = arr(i, j)
    
21.                             Next
    
22.                             brr(m, 14) = fn
    
23.                             For x = 1 To UBound(b)
    
24.                                 brr(m, x + 14) = .Range(b(x, 1)).Value
    
25.                             Next
    
26.                         End If
    
27.                     Next
    
28.                 End With
    
29.                 wb.Close False
    
30.             End If
    
31.         End If
    
32.     Next f
    
33.     With sh
    
34.         .[a4:z1000].ClearContents
    
35.         .Columns("M:N").NumberFormatLocal = "@"
    
36.         With .[b4].Resize(m, 24)
    
37.             .Value = brr
    
38.             .Borders.LineStyle = 1
    
39.             .HorizontalAlignment = xlCenter
    
40.             .VerticalAlignment = xlCenter
    
41.         End With
    
42.     End With
    
43.     Application.ScreenUpdating = True
    
44.     MsgBox "OK！"
    
45. End Sub
    

复制代码

cysczhumh

这个太复杂

yynrzwh

08.zip (748.65 KB, 下载次数: 9)

2024-8-20 17:40 上传

点击文件名下载附件

菊子红了

yynrzwh 发表于 2024-8-20 17:41

是我想要的效果，非常感谢！