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

wowo000

打搅各位老师周末休息，劳烦斧正附件里（不打开合并多簿多表且第一行的列标题名称如果相同则往下面叠加堆放，不同的列标亦罗列出来且数据也要）VBA代码，多谢！！！

捞屎人

我的贴i这里 有个 合并拆分工具可以的

zpy2

=A15=============
Attribute VB_Name = "模块1"
Sub 不打开合并多簿多表且列标题相同叠加在下()
    Dim mp, mn, aw, WbN, wn
    Dim wb As Workbook, Num
    Dim ge, e, endRow, endColumn
    Dim arr, i&, j&, k&, dic As Object, iRow&, iCol&, vItem
    Dim sht As Worksheet, brr
    Set dic = CreateObject("Scripting.Dictionary")
'    Dim brr(1 To 1048576, 1 To 100)
    Application.ScreenUpdating = False
    mp = ActiveWorkbook.Path
    mn = Dir(mp & "\" & "*.xls?")
    aw = ActiveWorkbook.Name
    Num = 0
    Do While mn <> ""
    If mn <> aw Then
       Set wb = Workbooks.Open(mp & "\" & mn)
       ge = ge + 1
       With Workbooks(1).ActiveSheet
            For i = 1 To Sheets.Count
                wb.Sheets(i).AutoFilterMode = False
                endColumn = wb.Sheets(i).UsedRange.Columns.Count
                endRow = wb.Sheets(i).UsedRange.Rows.Count '- 1
            Next
            ReDim brr(1 To 1048576, 1 To 100)
            iCol = 1: iRow = 1: brr(1, 1) = "数据源"
            
''            下面代码判定第一行的列标是否相同
            For i = 1 To Worksheets.Count
'                arr = wb.Sheets(i).Range(wb.Sheets(i).Cells(1, 1), wb.Sheets(i).Cells(endRow, endColumn))
                arr = wb.Sheets(i).UsedRange
                For j = 1 To UBound(arr, 2)
                debug.print j
                                debug.print arr(1,j)
                                stop
                                rem 在本地窗口看看是否 arr没有设置
                    If Not dic.exists(arr(1, j)) Then '这句代码通不过，提示如表里截图错别？？？
                       iCol = iCol + 1
                       brr(1, iCol) = arr(1, j)
                       dic(arr(1, j)) = iCol
                    End If
                Next j
            Next i
            
''            下面代码合并数据且如果列标相同则往下叠加
            For i = 1 To Sheets.Count
'                arr = wb.Sheets(i).Range(wb.Sheets(i).Cells(1, 1), wb.Sheets(i).Cells(endRow, endColumn))
                arr = wb.Sheets(i).UsedRange
                For j = 2 To UBound(arr)
                    iRow = iRow + 1
                    brr(iRow, 1) = wb.Name & wb.Sheets(i).Name
                    For k = 1 To UBound(arr, 2)
                        vItem = dic(arr(1, k))
                        brr(iRow, vItem) = arr(j, k)
                    Next k
                Next j
            Next i
            
''       将合并数据赋给当前工作表
       Set dic = Nothing
            Cells.Clear
            [a1].Resize(iRow, iCol) = brr
'            With [a1].CurrentRegion
'                  .HorizontalAlignment = xlCenter
'                  .Borders.LineStyle = xlContinuous
'                  .Rows(1).Font.Bold = True
'                  .EntireColumn.AutoFit
'                  .EntireRow.AutoFit
'            End With
            WbN = WbN & Chr(13) & wb.Name
            wb.Close False
       End With
    End If
    mn = Dir
    Loop
    Range("a1").Select
    Application.ScreenUpdating = True
    MsgBox "共合并了" & ge & "个工作薄下全部工作表。如下：" & vbCrLf & WbN, vbInformation, "提示"
End Sub

wowo000

捞屎人 发表于 2022-11-27 11:07
我的贴i这里 有个 合并拆分工具可以的

谢谢您的关注！你可能还没理解俺附件里的要求。可否劳烦理解后给整整？？？

捞屎人

wowo000 发表于 2022-11-27 11:14
谢谢您的关注！你可能还没理解俺附件里的要求。可否劳烦理解后给整整？？？

看你级别也不是这种小儿科问题能难住的 ，呵呵 。

捞屎人

y运行了一下 你的代码居然死机了   爱莫能助了

cpin

    把Set dic = CreateObject("Scripting.Dictionary")放在过程中，比如 ReDim brr后面，试下，我是猜测的。ReDim brr(1 To 1048576, 1 To 100)数组太大了！

wowo000

cpin 发表于 2022-11-27 12:13
把Set dic = CreateObject("Scripting.Dictionary")放在过程中，比如 ReDim brr后面，试下，我是猜测的 ...

谢谢您指教！！！

wowo000

zpy2 发表于 2022-11-27 11:12
=A15=============
Attribute VB_Name = "模块1"
Sub 不打开合并多簿多表且列标题相同叠加在下()

谢谢您的指教！多谢！

3190496160

Set dic = Nothing这句代码是在运行过程中的，移除了字典，肯定就会出现对象变量未设置的错误提示了。尅修改为，dic.RemoveAll，也就是清空字典，而不是移除字典，
只能是试试看看吧，你目前的代码，其实，整体思路就是不对的