不打开合并多簿多表且第一行的列标题相同叠加

zpy2 · 发表于 2022-11-27 13:11

wowo000 发表于 2022-11-27 12:20
谢谢您的指教！多谢！

Sub consolidate()

Dim wok As Workbook

Dim sht As Worksheet

Dim dic1 As Object

Set dic1 = CreateObject("scripting.dictionary")

Dim dic2 As Object

Set dic2 = CreateObject("scripting.dictionary")

'dic1代表每个不重复的工作表名

'dic2代表每个不重复的标题名

Application.DisplayAlerts = False

Application.ScreenUpdating = False

With Application.FileDialog(msoFileDialogFolderPicker)

      .Title = "（select folder）"

      If .Show = -1 Then

         FolderPath = .SelectedItems(1)

         fullPath = FolderPath & "\*.xls*"

         workbookName = Dir(fullPath)

         Do While workbookName <> ""

            workbookFullName = FolderPath & "\" & workbookName

            Set wok = Workbooks.Open(workbookFullName)

            For Each sht In wok.Worksheets

                  arr1 = sht.UsedRange

                  If Not dic1.exists(sht.Name) Then

                     '下面将工作簿的表头放入字典

                     Set dic2 = CreateObject("scripting.dictionary")

                     For j = 1 To UBound(arr1, 2)

                        dic2(arr1(1, j)) = ""

                     Next j



                     Set dic1(sht.Name) = dic2

                  Else

                     Set dic2 = dic1(sht.Name)

                     For j = 1 To UBound(arr1, 2)

                        dic2(arr1(1, j)) = ""

                     Next j

                     Set dic1(sht.Name) = dic2

                  End If

            Next sht

            workbookName = Dir

            wok.Close

         Loop

      End If

End With

For Each k1 In dic1.keys

      Dim arrResult()

      iRowNumberOfEachSheet = 1

      iColumnsNumber = 0

      '将arrResult写入表，表头就是dic1(k1)下的字典的键

      Set sht = Worksheets.Add()

      sht.Name = k1

      Erase arrResult

      ReDim Preserve arrResult(1 To dic1(k1).Count, 1 To iRowNumberOfEachSheet)

      For Each k2 In dic1(k1).keys

         iColumnsNumber = iColumnsNumber + 1

         arrResult(iColumnsNumber, iRowNumberOfEachSheet) = k2

      Next k2

      workbookName = Dir(fullPath)

      Do While workbookName <> ""

         workbookFullName = FolderPath & "\" & workbookName

         Set wok = Workbooks.Open(workbookFullName)

         Dim wsSourceWorksheet

         For Each wsSourceWorksheet In wok.Worksheets

            If wsSourceWorksheet.Name = k1 Then

                  arr1 = wsSourceWorksheet.UsedRange

                  For i = 2 To UBound(arr1, 1)

                     '将每行数据写入arrResult

                     iRowNumberOfEachSheet = iRowNumberOfEachSheet + 1

                     ReDim Preserve arrResult(1 To dic1(k1).Count, 1 To iRowNumberOfEachSheet)

                     iColumnCount = 0

                     For Each k2 In dic1(k1).keys

                     '匹配写入的列

                        iColumnCount = iColumnCount + 1

                        For j = 1 To UBound(arr1, 2)

                              If arr1(1, j) = k2 Then

                                 arrResult(iColumnCount, iRowNumberOfEachSheet) = arr1(i, j)

                                 Exit For

                              End If

                        Next j

                     Next k2

                  Next i

            End If

         Next wsSourceWorksheet

         sht.Range("a1").Resize(UBound(arrResult, 2), UBound(arrResult, 1)) = WorksheetFunction.Transpose(arrResult)

         workbookName = Dir

         wok.Close

      Loop

Next k1

Application.DisplayAlerts = True

      Application.ScreenUpdating = True

End Sub

这个也是论坛上的，也可以参考一下。

wowo000 · 发表于 2022-11-27 15:02

本帖最后由 wowo000 于 2022-11-27 15:10 编辑

3190496160 发表于 2022-11-27 12:24
Set dic = Nothing这句代码是在运行过程中的，移除了字典，肯定就会出现对象变量未设置的错误提示了。尅修 ...

尊敬的春风化雨老师：可否劳烦您抽空帮俺修理修理？多谢！！！

fzxba · 发表于 2022-11-27 15:29

练习.rar (805.1 KB, 下载次数: 27)

wowo000 · 发表于 2022-11-27 15:39

fzxba 发表于 2022-11-27 15:29

谢谢您！尊敬的fzxba老师！！虽然不是俺的意思，但还得感谢您！俺的要求将所有簿中的所有表都合并到一个工作表里。不过您这也提供了另一个不错的选择，谢谢您！！！

fzxba · 发表于 2022-11-27 15:42

本帖最后由 fzxba 于 2022-11-27 15:45 编辑

wowo000 发表于 2022-11-27 15:39
谢谢您！尊敬的fzxba老师！！虽然不是俺的意思，但还得感谢您！俺的要求将所有簿中的所有表都合并到一个 ...

难度不大……

我是练习试试。

cpin · 发表于 2022-11-27 16:15

鼓捣了一下，可以运行了

wowo000 · 发表于 2022-11-27 16:32

fzxba 发表于 2022-11-27 15:42
难度不大……

我是练习试试。

尊敬的fzxba老师：劳烦您抽空帮俺整一个附件吧？

fzxba · 发表于 2022-11-27 18:05

wowo000 发表于 2022-11-27 16:32
尊敬的fzxba老师：劳烦您抽空帮俺整一个附件吧？

Sub test2() '仅供测试
Dim ar, br, i As Long, Dic As Object, Dict As Object
Dim Conn As Object, rs As Object, Cata As Object, tb As Object
Dim strConn As String, s As String, p As String, f As String, t As String
Cells.Clear 'Contents
Application.ScreenUpdating = False
Set Dic = CreateObject("Scripting.Dictionary")
Set Dict = CreateObject("Scripting.Dictionary")
s = "Excel 12.0;HDR=yes;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;HDR=yes';Data Source="
Else
strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes';Data Source="
End If
Set Conn = CreateObject("ADODB.Connection")
Conn.Open strConn & ThisWorkbook.FullName
' Set rs = CreateObject("ADODB.Recordset")
Set Cata = CreateObject("ADOX.Catalog")
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.xls?")
While Len(f)
If p & f <> ThisWorkbook.FullName Then
Cata.ActiveConnection = strConn & p & f
For Each tb In Cata.Tables
If tb.Type = "TABLE" Then
t = Replace(tb.Name, "'", "")
If Right(t, 1) = "$" Then
Set rs = Conn.Execute("SELECT * FROM [" & s & p & f & "].[" & t & "A1:IV1] WHERE FALSE")
For i = 0 To rs.Fields.Count - 1
If Not rs.Fields(i).Name Like "F[1-9]*" Then Dic(rs.Fields(i).Name) = vbNullString
Next
End If
End If
Next
End If
f = Dir
Wend
br = Dic.Keys
Dic.RemoveAll
For i = 0 To UBound(br)
Range("C1").Offset(0, i) = br(i)
Dic.Add br(i), i
br(i) = "NULL AS " & br(i)
Next
Range("A1").Resize(, 2) = Split("工作簿名工作表名")
f = Dir(p & "*.xls?")
While Len(f)
If p & f <> ThisWorkbook.FullName Then
Cata.ActiveConnection = strConn & p & f
For Each tb In Cata.Tables
If tb.Type = "TABLE" Then
t = Replace(tb.Name, "'", "")
If Right(t, 1) = "$" Then
ar = br
Set rs = Conn.Execute("SELECT * FROM [" & s & p & f & "].[" & t & "A1:IV1] WHERE FALSE")
For i = 0 To rs.Fields.Count - 1
If Not rs.Fields(i).Name Like "F[1-9]*" Then
If Dic.Exists(rs.Fields(i).Name) Then ar(Dic(rs.Fields(i).Name)) = rs.Fields(i).Name
End If
Next
Dict.Add "SELECT '" & Split(f, ".xls")(0) & "','" & Left(t, Len(t) - 1) & "'," & Join(ar, ",") & " FROM [" & s & p & f & "].[" & t & "] WHERE LEN(客户编码)", vbNullString
If Dict.Count = 49 Then
Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset Conn.Execute(Join(Dict.Keys(), " UNION ALL "))
Dict.RemoveAll
End If
End If
End If
Next
End If
f = Dir
Wend
Set tb = Nothing
Set Cata = Nothing
If Dict.Count Then Cells(Rows.Count, 1).End(xlUp).Offset(1).CopyFromRecordset Conn.Execute(Join(Dict.Keys(), " UNION ALL "))
Set rs = Nothing
Conn.Close
Set Conn = Nothing
Set Dic = Nothing
Set Dict = Nothing
Application.ScreenUpdating = True
Beep
End Sub

复制代码

cpin · 发表于 2022-11-27 18:57

感觉您的程序很强大，再学习一下，看看是否是合适。

wowo000 · 发表于 2022-11-27 19:16

本帖最后由 wowo000 于 2022-12-9 18:51 编辑

cpin 发表于 2022-11-27 18:57
感觉您的程序很强大，再学习一下，看看是否是合适。

谢谢您！亲，cpin。再次谢谢您的关注，谢谢！

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

[求助] 不打开合并多簿多表且第一行的列标题相同叠加

评分

评分

评分

评分

评分

评分