工作表多个Sheet1汇总

limonet

关键字：Collection+dictionary

limonet

Sub limonet()
    Dim Sht As Worksheet, Cn As Object, Dic As Object, StrSQL$, F, Arr As Variant, CSet As New Collection
    Dim StrField$, Brr() As Variant, i%, j%
    Set Dic = CreateObject("scripting.dictionary")
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        Arr = Application.Transpose(Application.Transpose(Intersect(Sht.UsedRange, Sht.Rows(1)).Value))
        CSet.Add Arr
        i = i + 1: ReDim Preserve Brr(1 To i): Brr(i) = Sht.Name
        For Each F In CSet(i)
            Dic(F) = ""
        Next F
    Next Sht
    For i = 1 To CSet.Count
        If UBound(CSet(i)) = Dic.Count Then
            StrField = " *"
        Else
            For k = 1 To Dic.Count
                If UBound(Filter(CSet(i), Dic.keys()(k - 1))) <> -1 Then
                    StrField = StrField & "," & Dic.keys()(k - 1)
                Else
                    StrField = StrField & "," & "null as " & Dic.keys()(k - 1)
                End If
            Next k
        End If
        StrSQL = StrSQL & " Union all Select " & Mid(StrField, 2) & " From [" & Brr(i) & "$]"
        StrField = ""
    Next i
    Worksheets.Add(before:=Worksheets(1)).Name = "汇总"
    Set Rst = Cn.Execute(Mid(StrSQL, 12))
    For j = 0 To Rst.Fields.Count - 1
        Cells(1, j + 1) = Rst.Fields(j).Name
    Next j
    Range("A2").CopyFromRecordset Rst
End Sub

努力学习168

limonet 发表于 2024-5-27 22:12
关键字：Collection+dictionary

可以用，只是一次汇总，再次刷新就出错了。还是感谢!

努力学习168

ykcbf1100 发表于 2024-5-27 20:18
本来按字段合并已经写好了，上传前突然发现工作表复制是连标题一起复制的，所以，又重新写了一个。

没有问题了，感谢！

ykcbf1100

jjmysjg 发表于 2024-5-27 21:43
按字段合并的代码，合并的数据不全呢

我这个代码不是按字段合并的，按楼主的意思就是简单合并一下。

LIUZHU

这个标题也要合并么？标题不共用吗？

LIUZHU

简单合并，就是这样，没什么技术含量的

LIUZHU

JSA代码很简单的

1. function 工作表汇总(){
   
2.         let res=[...Sheets].reduce((res,sh)=>(/\d+/.test(sh.Name)?res.push(...sh.UsedRange.Value2):null,res),[]);
   
3.         Range("a1").Resize(res.length,res[0].length).Value2=res;
   
4. }

复制代码

LIUZHU

WPS打开审核，运行JS宏

努力学习168

LIUZHU 发表于 2024-5-28 10:47
WPS打开审核，运行JS宏

感谢，我的是office，下次安排试下。