如何将多个工作簿按设定格式合并到同一工作簿中

msw2395

Qs18 发表于 2024-7-20 10:59
试一下...........

可以的，谢谢！！

ykcbf1100

参与一下。。。

ykcbf1100

练手。。。

1. Sub ykcbf()  '//2024.7.20  多工作簿合并
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Set sh = ThisWorkbook.Sheets("汇总")
   
5.     sh.UsedRange.Clear
   
6.     p = ThisWorkbook.Path & ""
   
7.     For Each f In fso.GetFolder(p).Files
   
8.         If LCase$(f.Name) Like "*.xls*" Then
   
9.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
   
10.                 m = m + 1
    
11.                 Set wb = Workbooks.Open(f, 0)
    
12.                 With wb.Sheets(1)
    
13.                     r = .Cells(Rows.Count, 1).End(3).Row
    
14.                     c = .UsedRange.Columns.Count
    
15.                     arr = .[a1].Resize(r, c)
    
16.                 End With
    
17.                 wb.Close False
    
18.                 If m = 1 Then
    
19.                     sh.Cells(1, 1).Resize(r, c) = arr
    
20.                 Else
    
21.                     col = sh.Cells(1, 255).End(1).Column + 2
    
22.                     sh.Cells(1, col).Resize(r, c) = arr
    
23.                 End If
    
24.             End If
    
25.         End If
    
26.     Next f
    
27.     Application.ScreenUpdating = True
    
28.     MsgBox "OK！"
    
29. End Sub
    

复制代码

今日123

借用前辈的代码
Sub 合并多本数据()
  
  Dim Conn As Object, dict As Object, target As Range
  Dim strConn As String, p As String, f As String, s As String
  
  Set target = Range("A1")
  target.CurrentRegion.ClearContents
  Application.ScreenUpdating = False
  
  Set dict = CreateObject("Scripting.Dictionary")
  Set Conn = CreateObject("ADODB.Connection")
  s = "Excel 12.0;HDR=NO;Database="
  If Application.Version < 12 Then
    s = Replace(s, "12.0", "8.0")
    strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source="
  Else
    strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source="
  End If
  Conn.Open strConn & ThisWorkbook.FullName
  
  p = ThisWorkbook.Path & "\"
  f = Dir(p & "*.xlsx")
  
  While Len(f)
    If p & f <> ThisWorkbook.FullName Then
      dict.Add "SELECT * FROM [" & s & p & f & "].[$A1:F] WHERE LEN(F1)", ""
      If dict.Count = 49 Then
        target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
        Set target = Cells(Rows.Count, "A").End(xlUp).Offset(1)
        dict.RemoveAll
      End If
    End If
    f = Dir
  Wend
  
  If dict.Count Then target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
  
  Conn.Close
  Set Conn = Nothing
  Set target = Nothing
  Set dict = Nothing

  Application.ScreenUpdating = True
  
End Sub

jjmysjg

横向合并工作簿的表一