恳请高手师傅们帮忙看下这个提取制定内容的汇总

qiongmei6

我希望在流水工作簿中求得一个代码，他执行后在流水工作簿内a：x列汇总同一文件夹内其他文件第4行之后的内容，目前的流水表格就是我希望得到的最后结果，谢谢高手师傅们的帮忙。

fzxba

新建文件夹 (3).rar (30.94 KB, 下载次数: 12)

2023-3-15 17:33 上传

点击文件名下载附件

qiongmei6

谢谢二楼师傅的回答，因为我的版本excel是2003版的，这个代码在我的电脑运行出现错误，能否麻烦您再修改下，再次谢谢您的帮忙

3190496160

Sub 汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("流水")
    .[a1].CurrentRegion.Offset(1) = Empty
    ar = .Range("a1:x5000")
    For j = 1 To UBound(ar, 2)
        d(Trim(ar(1, j))) = j
    Next j
    f = Dir(ThisWorkbook.Path & "\*.xls*")
    n = 1
    Do While f <> ""
        If f <> ThisWorkbook.Name Then
            Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & f, 0)
            With wb.Worksheets(1)
                r = .Cells(Rows.Count, 1).End(xlUp).Row
                br = .Range("a4:x" & r)
            End With
            wb.Close False
            For i = 2 To UBound(br)
                If Trim(br(i, 1)) <> "" Then
                    n = n + 1
                    For j = 1 To UBound(br, 2)
                        lh = d(Trim(br(1, j)))
                        If lh <> "" Then
                            ar(n, lh) = br(i, j)
                        End If
                    Next j
                End If
            Next i
        End If
    f = Dir
    Loop
    .[a1].Resize(n, UBound(ar, 2)) = ar
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

3190496160

新建文件夹 (3).rar (35 KB, 下载次数: 6)

2023-3-15 19:39 上传

点击文件名下载附件

fzxba

qiongmei6 发表于 2023-3-15 17:41
谢谢二楼师傅的回答，因为我的版本excel是2003版的，这个代码在我的电脑运行出现错误，能否麻烦您再修改下 ...

代码成熟通用，不必更改。
只因你的源文件为某系统导出，解决方法为打开再另存（可用代码实现）……
这样，倒不如直接用 workbooks.open 方法省事。