按照标题字段汇集所选定文件件里的所有工作簿

ykcbf1100

jjmysjg 发表于 2024-4-6 11:13
增加一个功能：各簿的所有表合并进去(这个是合并第1个表的)

不是，是所有工作簿的

ooluckydog

jjmysjg 发表于 2024-4-6 11:03
这是合并各簿的第1个工作表。
要合并各簿的所有表，怎么修改？
谢谢！

可以汇总所有工作簿的所有工作表，汇集表中可以没有标题

Sub 按字段汇总工作簿()
    Dim i&, j&, k&, m&
    Dim arData As Variant
    Dim wb As Workbook
    Dim d As Object
    Dim c As New Collection

    Set d = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Sheets("汇集表")
        For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            If Not d.exists(.Cells(1, j).Value) And .Cells(1, j).Value <> "" Then
                d.Add .Cells(1, j).Value, j
            End If
        Next j
    End With

    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Add "Excel files", "*.xlsx; *.xls", 1
        .AllowMultiSelect = True
        If .Show = -1 Then
            For k = 1 To .SelectedItems.Count
                With GetObject(.SelectedItems(k))
                    For i = 1 To .Worksheets.Count
                        c.Add .Worksheets(i).[a1].CurrentRegion.Value
                    Next i
                End With
            Next k
        Else
            MsgBox "取消了文件选择！": Exit Sub
        End If
    End With

    For k = 1 To c.Count
        m = m + UBound(c(k))
        For j = 1 To UBound(c(k), 2)
            If Not d.exists(c(k)(1, j)) Then d.Add c(k)(1, j), d.Count + 1
        Next j
    Next k

    ReDim arData(1 To m, 1 To d.Count)
    For j = 1 To d.Count
        arData(1, j) = d.keys()(j - 1)
    Next j

    m = 1
    For k = 1 To c.Count
        For i = 2 To UBound(c(k))
            m = m + 1
            For j = 1 To UBound(c(k), 2)
                arData(m, d(c(k)(1, j))) = c(k)(i, j)
            Next j
        Next i
    Next k

    With ThisWorkbook.Sheets("汇集表")
        .Cells.ClearContents
        .[a1].Resize(UBound(arData), UBound(arData, 2)) = arData
    End With
End Sub

ooluckydog

可以汇总所选工作簿中所有工作表，汇集表中也可以不写标题

Sub 按字段汇总工作簿()
    Dim i&, j&, k&, m&
    Dim arData As Variant
    Dim wb As Workbook
    Dim d As Object
    Dim c As New Collection
   
    Set d = CreateObject("Scripting.Dictionary")
    With ThisWorkbook.Sheets("汇集表")
        For j = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
            If Not d.exists(.Cells(1, j).Value) And .Cells(1, j).Value <> "" Then
                d.Add .Cells(1, j).Value, j
            End If
        Next j
    End With
   
    With Application.FileDialog(msoFileDialogFilePicker)
        .Filters.Add "Excel files", "*.xlsx; *.xls", 1
        .AllowMultiSelect = True
        If .Show = -1 Then
            For k = 1 To .SelectedItems.Count
                With GetObject(.SelectedItems(k))
                    For i = 1 To .Worksheets.Count
                        c.Add .Worksheets(i).[a1].CurrentRegion.Value
                    Next i
                End With
            Next k
        Else
            MsgBox "取消了文件选择！": Exit Sub
        End If
    End With
   
    For k = 1 To c.Count
        m = m + UBound(c(k))
        For j = 1 To UBound(c(k), 2)
            If Not d.exists(c(k)(1, j)) Then d.Add c(k)(1, j), d.Count + 1
        Next j
    Next k
   
    ReDim arData(1 To m, 1 To d.Count)
    For j = 1 To d.Count
        arData(1, j) = d.keys()(j - 1)
    Next j
   
    m = 1
    For k = 1 To c.Count
        For i = 2 To UBound(c(k))
            m = m + 1
            For j = 1 To UBound(c(k), 2)
                arData(m, d(c(k)(1, j))) = c(k)(i, j)
            Next j
        Next i
    Next k
   
    With ThisWorkbook.Sheets("汇集表")
        .Cells.ClearContents
        .[a1].Resize(UBound(arData), UBound(arData, 2)) = arData
    End With
End Sub

wowo000

ykcbf1100 发表于 2024-4-6 11:07
更简单了，代码更少。

尊敬的ykcbf1100老师：今日鲜花送完，明天补上。非常抱歉，请海涵！

ykcbf1100

wowo000 发表于 2024-4-6 12:11
尊敬的ykcbf1100老师：今日鲜花送完，明天补上。非常抱歉，请海涵！

花不花的其实不重要，心意到了就可以了。

jjmysjg

ykcbf1100 发表于 2024-4-6 11:07
更简单了，代码更少。

大侠你好：各个表的表头是4行的含有合并单元格的，能实现吗。

ykcbf1100

jjmysjg 发表于 2024-4-6 14:12
大侠你好：各个表的表头是4行的含有合并单元格的，能实现吗。

上个附件看看。

blackttea1

好程序，谢谢