[已解决]如何汇总文件夹内表格的所有内容

531tommy

请问如何获取文件夹内的所有内容到同一表格上，汇总表格A列为文件名字。
仓库.zip (31.43 KB, 下载次数: 15)

2022-5-16 17:19 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hasyh2008

2022-5-17 13:18

Sub 复制()
  Dim MyName As String
  Dim Arr(), Brr
  Dim K%
  Dim Wb1 As Workbook
  Dim Wb2 As Workbook
  Dim MyFile As Object
  Set MyFile = CreateObject("Scripting.FileSystemObject")
  Set Wb1 = ThisWorkbook
  MyName = Dir(ThisWorkbook.Path & "\", vbDirectory)
  K = 1
  Do While MyName <> ""
      If InStr(MyName, ".xlsx") > 0 Then
          ReDim Preserve Arr(1 To K)
          Arr(K) = ThisWorkbook.Path & "\" & MyName
          K = K + 1
      End If
      MyName = Dir
  Loop
  Application.ScreenUpdating = False
  Set Wb1 = ThisWorkbook
  Wb1.Sheets(1).Range("A1").CurrentRegion.Offset(1, 0) = ""
  For K = 1 To UBound(Arr)
    R1 = Wb1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    Set Wb2 = GetObject(Arr(K))
    R2 = Wb2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    Brr = Wb2.Sheets(1).Range("A2:E" & R2)
    Wb1.Sheets(1).Cells(R1 + 1, 2).Resize(UBound(Brr), 5) = Brr
    Wb1.Sheets(1).Cells(R1 + 1, 1).Resize(UBound(Brr), 1) = MyFile.GetBaseName(Wb2.FullName)
  Next K
  Wb2.Close False
  Set Wb1 = Nothing
  Set Wb2 = Nothing
  Set MyFile = Nothing
  Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

hasyh2008

1. Sub text()
   
2.   Application.ScreenUpdating = False
   
3.   Dim Arr, R1%, R2%, FileName, X%
   
4.   Dim Wb1 As Workbook
   
5.   Dim Wb2 As Workbook
   
6.   Set Wb1 = ThisWorkbook
   
7.   Wb1.Sheets(1).Range("A2:F10000") = ""
   
8.   FileName = Application.GetOpenFilename("EXCEL文件,*.xls*", MultiSelect:=True)
   
9.   For X = 1 To UBound(FileName)
   
10.     R1 = Wb1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    
11.     Set Wb2 = GetObject(FileName(X))
    
12.     R2 = Wb2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    
13.     Arr = Wb2.Sheets(1).Range("A2:E" & R2)
    
14.     Wb1.Sheets(1).Cells(R1 + 1, 2).Resize(UBound(Arr), 5) = Arr
    
15.     Wb1.Sheets(1).Cells(R1 + 1, 1).Resize(UBound(Arr), 1) = Wb2.Name
    
16.   Next X
    
17.   Set Wb1 = Nothing
    
18.   Set Wb2 = Nothing
    
19.   Application.ScreenUpdating = True
    
20. End Sub

复制代码

531tommy

hasyh2008 发表于 2022-5-16 22:09

十分感谢，但操作上能否把A列的后缀.XLS去掉。另外能否直接把文件夹内的所有文件自动选择，无需打开对话框自己手动选择

hasyh2008

Sub 复制()
  Dim MyName As String
  Dim Arr(), Brr
  Dim K%
  Dim Wb1 As Workbook
  Dim Wb2 As Workbook
  Set Wb1 = ThisWorkbook
  MyName = Dir(ThisWorkbook.Path & "\", vbDirectory)
  K = 1
  Do While MyName <> ""
      If InStr(MyName, ".xlsx") > 0 Then
          ReDim Preserve Arr(1 To K)
          Arr(K) = ThisWorkbook.Path & "\" & MyName
          K = K + 1
      End If
      MyName = Dir
  Loop
  Application.ScreenUpdating = False
  Set Wb1 = ThisWorkbook
  Wb1.Sheets(1).Range("A2:F10000") = ""
  For K = 1 To UBound(Arr)
    R1 = Wb1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    Set Wb2 = GetObject(Arr(K))
    R2 = Wb2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    Brr = Wb2.Sheets(1).Range("A2:E" & R2)
    Wb1.Sheets(1).Cells(R1 + 1, 2).Resize(UBound(Brr), 5) = Brr
    Wb1.Sheets(1).Cells(R1 + 1, 1).Resize(UBound(Brr), 1) = Wb2.Name
    ActiveSheet.Cells.Replace what:=".xlsx", Replacement:="", lookat:=xlPart, MatchCase:=True
  Next K
  Wb2.Close False
  Set Wb1 = Nothing
  Set Wb2 = Nothing
  Application.ScreenUpdating = True
End Sub

hasyh2008

Sub 复制()
  Dim MyName As String
  Dim Arr(), Brr
  Dim K%
  Dim Wb1 As Workbook
  Dim Wb2 As Workbook
  Dim MyFile As Object
  Set MyFile = CreateObject("Scripting.FileSystemObject")
  Set Wb1 = ThisWorkbook
  MyName = Dir(ThisWorkbook.Path & "\", vbDirectory)
  K = 1
  Do While MyName <> ""
      If InStr(MyName, ".xlsx") > 0 Then
          ReDim Preserve Arr(1 To K)
          Arr(K) = ThisWorkbook.Path & "\" & MyName
          K = K + 1
      End If
      MyName = Dir
  Loop
  Application.ScreenUpdating = False
  Set Wb1 = ThisWorkbook
  Wb1.Sheets(1).Range("A1").CurrentRegion.Offset(1, 0) = ""
  For K = 1 To UBound(Arr)
    R1 = Wb1.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    Set Wb2 = GetObject(Arr(K))
    R2 = Wb2.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row
    Brr = Wb2.Sheets(1).Range("A2:E" & R2)
    Wb1.Sheets(1).Cells(R1 + 1, 2).Resize(UBound(Brr), 5) = Brr
    Wb1.Sheets(1).Cells(R1 + 1, 1).Resize(UBound(Brr), 1) = MyFile.GetBaseName(Wb2.FullName)
  Next K
  Wb2.Close False
  Set Wb1 = Nothing
  Set Wb2 = Nothing
  Set MyFile = Nothing
  Application.ScreenUpdating = True
End Sub

531tommy

hasyh2008 发表于 2022-5-17 13:18
Sub 复制()
  Dim MyName As String
  Dim Arr(), Brr

十分感谢。