汇总同一文件夹中的工作簿

石来运转6888 · 发表于 2024-5-5 18:38

利用汇总表头的字段汇总同一个文件夹内的各个工作簿中各个工作表对应数据，请大神指导，谢谢。

gwjkkkkk · 发表于 2024-5-5 19:23

Option Explicit
Sub test()
Dim strFileName$, strPath$, wks As Worksheet
Dim ar, strResult$(), i&, j&, r&, dic As Object, iPosCol&

Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")

ar = Range("A2:G2").Value
ReDim strResult(1 To 10 ^ 5, 1 To UBound(ar, 2))
r = 1
For j = 1 To UBound(ar, 2)
      dic(ar(1, j)) = j
      strResult(r, j) = ar(1, j)
Next j

strPath = ThisWorkbook.Path & "\"
strFileName = Dir(strPath & "*.xls*")
Do Until strFileName = ""
      If strFileName <> ThisWorkbook.Name Then
         With GetObject(strPath & strFileName)
            For Each wks In .Worksheets
                  If wks.[B2].Value = "单号" Then
                     ar = wks.[A1].CurrentRegion.Value
                     For i = 3 To UBound(ar)
                        r = r + 1
                        For j = 1 To UBound(ar, 2)
                              If dic.exists(ar(2, j)) Then
                                 iPosCol = dic(ar(2, j))
                                 strResult(r, iPosCol) = ar(i, j)
                              End If
                        Next j
                     Next i
                  End If
            Next
            .Close False
         End With
      End If
      strFileName = Dir
Loop

With [A2].Resize(r, UBound(strResult, 2))
      .Clear
      .Value = strResult
      .HorizontalAlignment = xlCenter
      .Borders.LineStyle = xlContinuous
      .EntireColumn.AutoFit
      .EntireRow.AutoFit
End With
Set wks = Nothing
Application.ScreenUpdating = True
Beep
End Sub

gwjkkkkk · 发表于 2024-5-5 19:25

请参考。。。

ykcbf1100 · 发表于 2024-5-5 20:02

本帖最后由 ykcbf1100 于 2024-5-5 20:56 编辑

刚才代码有误，更新一下。

ykcbf1100 · 发表于 2024-5-5 20:03

本帖最后由 ykcbf1100 于 2024-5-5 20:57 编辑

参与一下。。。

Sub ykcbf() '//2024.5.5
Set fso = CreateObject("scripting.filesystemobject")
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Sheets("汇总表")
With sh
For j = 1 To 7
s = .Cells(2, j)
d(s) = j
Next
End With
p = ThisWorkbook.Path & ""
ReDim brr(1 To 10000, 1 To 10)
For Each f In fso.GetFolder(p).Files
If f.Name Like "*.xls*" Then
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
fn = fso.GetBaseName(f)
Set wb = Workbooks.Open(f, 0)
For Each sht In wb.Sheets
If sht.[b2].Value = "单号" Then
With sht
r = .Cells(Rows.Count, 2).End(3).Row
arr = .[a1].Resize(r, 8)
End With
For i = 3 To UBound(arr)
If arr(i, 2) <> Empty Then
M = M + 1
For j = 1 To UBound(arr, 2)
s = arr(2, j)
If d.exists(s) Then
brr(M, d(s)) = arr(i, j)
End If
Next
End If
Next
End If
Next
wb.Close False
End If
End If
Next f
On Error Resume Next
With sh
.[a3:g10000].Clear
.[a2].Resize(1, 7).Interior.Color = 49407
.Columns("e:g").NumberFormatLocal = "@"
With .[a3].Resize(M, 7)
.Value = brr
.Borders.LineStyle = 1
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

yanglinzi · 发表于 2024-5-5 21:53

Sub sd汇总()
Dim arr, brr, i, j, r, d, sht
Set d = CreateObject("scripting.dictionary")
Set fso = CreateObject("scripting.filesystemobject")
p = ThisWorkbook.Path & ""
crr = Sheets("汇总表").Range("a2").CurrentRegion
For i = 1 To UBound(crr, 2)
If crr(1, i) <> "" Then
sa = crr(1, i)
d(sa) = i
End If
Next
ReDim brr(1 To 100000, 1 To 7)
For Each f In fso.getfolder(p).Files
If f.Name <> ThisWorkbook.Name Then
Set wb = Workbooks.Open(f)
For Each sh In Sheets
Debug.Print sh.Name
If sh.[b2] = "单号" Then
arr = sh.UsedRange
For i = 3 To UBound(arr)
If arr(i, 2) & arr(i, 3) <> Empty Then
n = n + 1
For j = 1 To UBound(arr, 2)
sb = arr(2, j)
If d.exists(sb) Then
brr(n, d(sb)) = arr(i, j)
End If
Next
End If
Next
End If
Next
wb.Close False
End If
Next
With Sheet1
.[g:g].NumberFormatLocal = "@"
.[a3].Resize(n, 7) = brr
End With
End Sub

复制代码

yanglinzi · 发表于 2024-5-5 21:54

请测试。。

ykcbf1100 · 发表于 2024-5-6 09:13

yanglinzi 发表于 2024-5-5 21:54
请测试。。

你这For Each sh In Sheets应该是For Each sh In wb.Sheets吧。
你这代码有没有验证过啊。

baofa2 · 发表于 2024-5-6 12:32

Sub test1() '参与练习 ……
Sheet1.Activate
ActiveSheet.UsedRange.Offset(2).ClearContents
Application.ScreenUpdating = False
Dim strPath As String, strFile As String
Dim ar, br, dic As Object, dict As Object, target As Range
Dim Conn As Object, rs As Object, Cata As Object, tb As Object
Dim strConn As String, SQL As String, Field As String
Dim s As String, t As String, i As Long
Set target = Range("A3")
Set dict = CreateObject("Scripting.Dictionary")
Set dic = CreateObject("Scripting.Dictionary")
Set Cata = CreateObject("ADOX.Catalog")
Set Conn = CreateObject("ADODB.Connection")
ar = Application.Rept(Range("A1").CurrentRegion.Rows(2).Value, 1)
For i = 1 To UBound(ar)
Field = "`" & ar(i) & "`"
dic.Add Field, i
ar(i) = "'' AS " & Field
Next
s = "Excel 12.0;HDR=YES;IMEX=1;Database="
If Application.Version < 12 Or InStr(Application.Path, "WPS") > 0 Then
s = Replace(s, "12.0", "8.0")
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=YES';Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=YES';Data Source="
End If
strPath = ThisWorkbook.Path & "\"
strFile = Dir(strPath & "*.xls*")
While Len(strFile)
If strPath & strFile <> ThisWorkbook.FullName Then
If Conn.State <> 1 Then
Conn.Open strConn & strPath & strFile
Cata.ActiveConnection = Conn
Else
Cata.ActiveConnection = strConn & strPath & strFile
End If
For Each tb In Cata.Tables
If tb.Type = "TABLE" Then
t = Replace(tb.Name, "'", vbNullString)
If Right(t, 1) = "$" Then
SQL = "SELECT * FROM [" & s & strPath & strFile & "].[" & t & "A2:Z] WHERE FALSE"
Set rs = Conn.Execute(SQL)
If rs.Fields(1).Name = "单号" Then
br = ar
For i = 0 To rs.Fields.Count - 1
Field = "`" & rs.Fields(i).Name & "`"
If dic.Exists(Field) Then br(dic(Field)) = Field
Next
SQL = "SELECT " & Join(br, ",") & " FROM [" & s & strPath & strFile & "].[" & t & "A2:Z] WHERE LEN(单号)>0 OR LEN(品名)>0"
dict.Add SQL, vbNullString
If dict.Count = 49 Then
target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
Set target = Range("A" & Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1)
dict.RemoveAll
End If
End If
End If
End If
Next
End If
strFile = Dir
Wend
If dict.Count Then target.CopyFromRecordset Conn.Execute(Join(dict.Keys, " UNION ALL "))
Set target = Nothing
Set Cata = Nothing
rs.Close: Set rs = Nothing
Conn.Close: Set Conn = Nothing
Set dic = Nothing: Set dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

汇总同一文件夹中的工作簿

评分

评分

评分

评分

浏览过的版块