简单汇总，需要修改一下代码！

Qs18 · 发表于 2024-8-28 10:07

试试........

ykcbf1100 · 发表于 2024-8-28 10:33

扇扇扇发表于 2024-8-28 09:35
Dim Wirtesht As Worksheet
Set Wirtesht = ActiveSheet ...

还有A列数据需要写入，所以，你还得再加几句代码。

扇扇扇 · 发表于 2024-8-28 12:01

ykcbf1100 发表于 2024-8-28 10:33
还有A列数据需要写入，所以，你还得再加几句代码。

A列不是加了一句复制吗

辉太狼－2014 · 发表于 2024-8-31 23:06

ykcbf1100 发表于 2024-8-28 07:55
参与一下。。。

因为表格微调了一下如图1（该文件就是ThisWorkbook），我也微调了下代码，如下

Sub ykcbf() '//2024.8.28 多表合并
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
p = ThisWorkbook.Path & "\"
Set ws = ThisWorkbook
Set sh = ws.Sheets("Sheet1")
ReDim brr(1 To 10000, 1 To 100)
For Each f In fso.GetFolder(p).Files
      If LCase(f.Name) Like "*.xls*" Then
         If InStr(f, "~$") = 0 Then
            If InStr(f, ws.Name) = 0 Then
                  fn = fso.GetBaseName(f)
                  Set wb = Workbooks.Open(f, 0)
                  With wb.Sheets(1)
                     r = .Cells(Rows.Count, 1).End(3).Row
                     c = .Cells(3, "XFD").End(1).Column
                     arr = .[a1].Resize(r, c)
                  End With
                  wb.Close 0
                  For i = 4 To UBound(arr)                      ' 这里改成3改成4
                     If arr(i, 1) <> Empty Then
                        m = m + 1
                        brr(m, 1) = fn
                        For j = 1 To UBound(arr, 2)
                              brr(m, j + 1) = arr(i, j)
                        Next
                     End If
                  Next
            End If
         End If
      End If
Next
With sh
      .UsedRange.Offset(2).ClearContents
      .[a4].Resize(m, c) = brr                                        '这里A3改成A4
End With
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

但是改好后出现如图-微改代码后的现象