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

辉太狼－2014

Dim Wirtesht As Worksheet                                       
Set Wirtesht = ActiveSheet                                   
Dim Location As String, FileName As String                    
Location = "C:\Users\Administrator\Desktop\新建文件夹 (5)\8月\"
FileName = Dir(Location & "*.xlS")                             
Dim OpenBok As Workbook                                 
Do While FileName <> ""                                       
  Set OpenBok = Workbooks.Open(Location & FileName)
  With OpenBok.Sheets(1).UsedRange                              
      .Rows(4 & ":" & .Rows.Count).Copy Wirtesht.Range("A" & Wirtesht.Rows.Count).End(xlUp).Offset(1, 0)
  End With
  OpenBok.Close Savechanges = False
  FileName = Dir
Loop
End Sub

扇扇扇

这是要改什么

辉太狼－2014

扇扇扇 发表于 2024-8-27 22:26
这是要改什么

可能我表达的不够清晰，我原先汇总的表格是这样的（原帖的图一），然后我在图一的表格加了一列，A列，需要把下面的图一，红圈的内容，汇总到图二红圈的位置

ykcbf1100

多表合并

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.28    多表合并
   
2.     Application.ScreenUpdating = False
   
3.     Set fso = CreateObject("Scripting.FileSystemObject")
   
4.     p = ThisWorkbook.Path & ""
   
5.     Set ws = ThisWorkbook
   
6.     Set sh = ws.Sheets("Sheet1")
   
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, "~$") = 0 Then
    
11.                 If InStr(f, ws.Name) = 0 Then
    
12.                     fn = fso.GetBaseName(f)
    
13.                     Set wb = Workbooks.Open(f, 0)
    
14.                     With wb.Sheets(1)
    
15.                         r = .Cells(Rows.Count, 1).End(3).Row
    
16.                         c = .Cells(3, "XFD").End(1).Column
    
17.                         arr = .[a1].Resize(r, c)
    
18.                     End With
    
19.                     wb.Close 0
    
20.                     For i = 3 To UBound(arr)
    
21.                         If arr(i, 1) <> Empty Then
    
22.                             m = m + 1
    
23.                             brr(m, 1) = fn
    
24.                             For j = 1 To UBound(arr, 2)
    
25.                                 brr(m, j + 1) = arr(i, j)
    
26.                             Next
    
27.                         End If
    
28.                     Next
    
29.                 End If
    
30.             End If
    
31.         End If
    
32.     Next
    
33.     With sh
    
34.         .UsedRange.Offset(2).ClearContents
    
35.         .[a3].Resize(m, c) = brr
    
36.     End With
    
37.     Application.ScreenUpdating = True
    
38.     MsgBox "OK！"
    
39. End Sub
    

复制代码

辉太狼－2014

ykcbf1100 发表于 2024-8-28 07:54
多表合并

附件供参考。。。

又是大哥你指点帮忙！十分感谢！上次你帮忙弄的代码，还在消化中，也谢谢你！

ykcbf1100

辉太狼－2014 发表于 2024-8-28 08:49
又是大哥你指点帮忙！十分感谢！上次你帮忙弄的代码，还在消化中，也谢谢你！

汇总表多了一列，原代码就需要修改一下。但是，原代码不是我喜欢的风格，所以就没改。

扇扇扇

Dim Wirtesht As Worksheet                                       
Set Wirtesht = ActiveSheet                                   
Dim Location As String, FileName As String                    
Location = "C:\Users\Administrator\Desktop\新建文件夹 (5)\8月\"
FileName = Dir(Location & "*.xlS")                             
Dim OpenBok As Workbook                                 
Do While FileName <> ""                                       
  Set OpenBok = Workbooks.Open(Location & FileName)
  With OpenBok.Sheets(1).UsedRange                              
      .Rows(4 & ":" & .Rows.Count).Copy Wirtesht.Range("B" & Wirtesht.Rows.Count).End(xlUp).Offset(1, 0)

      lr = .Range("a65536").End(xlUp).Row
      .Range("B2").Copy Wirtesht.Range("A" & Wirtesht.Rows.Count).End(xlUp).Offset(1, 0).Resize(lr - 3, 1)
  End With
  OpenBok.Close Savechanges = False
  FileName = Dir
Loop
End Sub

在你原代码修改一处并增加两句。

Qs18

Sub qs()
Dim fso As Object, folderPath As String, file As Object, wb As Workbook, xb As Workbook
Set wb = ThisWorkbook
myname = ThisWorkbook.Name
Set dic = CreateObject("scripting.dictionary")
ph = ThisWorkbook.Path
    Application.ScreenUpdating = False
    Set fso = CreateObject("Scripting.FileSystemObject")
    folderPath = ph
    If fso.FolderExists(folderPath) Then
        Set folder = fso.GetFolder(folderPath)
        For Each file In folder.Files
            If file.Name <> myname Then
            If LCase(fso.GetExtensionName(file.Name)) = "xlsx" Or _
               LCase(fso.GetExtensionName(file.Name)) = "xls" Then
                Set xb = Workbooks.Open(ph & "\" & file.Name, 0)
                arr = xb.Sheets(1).Range("a2").CurrentRegion.Value
                ar = xb.Sheets(1).Range("a4:h" & UBound(arr))
                xb.Close (0)
                rw = wb.Sheets(1).Cells(Rows.Count, "b").End(3).Row + 1
                wb.Sheets(1).Range("b" & rw).Resize(UBound(ar), UBound(ar, 2)) = ar
                wb.Sheets(1).Range("a" & rw).Resize(UBound(ar), 1) = arr(2, 2)
            End If
        End If
        Next file
    Else
        MsgBox "指定的文件夹不存在。"
    End If
    Set fso = Nothing: Set wb = Nothing
    Set folder = Nothing: Set xb = Nothing
    Application.ScreenUpdating = True
    MsgBox "完成！"
End Sub

Qs18

试试.......