多个单元表汇总

app240913

大家好，表格有很多个sheet，每个sheet是一个公司的送货数据，有送货公司名称，日期，单号，送货明细（产品和数量）
需要按固定表头汇总

wang-way

早起搬砖工

cyq4896

参与一下....

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.9.13
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set sh = ThisWorkbook.Sheets("汇总")
   
4.     ReDim brr(1 To 10000, 1 To 6)
   
5.     For Each sht In Sheets
   
6.         If sht.Name <> sh.Name Then
   
7.             arr = sht.UsedRange
   
8.             For j = 2 To UBound(arr, 2)
   
9.                 For i = 5 To UBound(arr)
   
10.                     s = arr(1, 1) & "|" & arr(2, j) & "|" & arr(3, j) & "|" & arr(i, 1)
    
11.                     If Not d.exists(s) Then
    
12.                         m = m + 1
    
13.                         d(s) = m
    
14.                         brr(m, 1) = arr(3, j)
    
15.                         brr(m, 2) = arr(1, 2)
    
16.                         brr(m, 3) = arr(2, j)
    
17.                         brr(m, 4) = arr(i, 1)
    
18.                         brr(m, 5) = arr(i, j)
    
19.                         brr(m, 6) = sht.Name
    
20.                     Else
    
21.                         r = d(s)
    
22.                         brr(r, 5) = brr(r, 5) + arr(i, j)
    
23.                     End If
    
24.                 Next
    
25.             Next
    
26.         End If
    
27.     Next
    
28.     With sh
    
29.         .UsedRange.Offset(1).ClearContents
    
30.         .[a2].Resize(m, 6) = brr
    
31.     End With
    
32.     MsgBox "OK！"
    
33. End Sub
    

复制代码

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, Sht As Worksheet, i%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
    Arr = Intersect(Sht.Range("A1").CurrentRegion, Sht.Range("B1:H3"))
        For i = 1 To UBound(Arr, 2)
            StrSQL = StrSQL & " Union All Select #" & Arr(3, i) & "#,'" & Arr(1, 1) & "','" & Arr(2, i) & "',F1,F" & i + 1 & ",'" & Sht.Name & "' From [C$A5:E]"
        Next i
    Next Sht
    Range("A15").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

limonet

关键字：union all

limonet

Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, Sht As Worksheet, i%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name <> "汇总" Then
            Arr = Intersect(Sht.Range("A1").CurrentRegion, Sht.Range("B1:H3"))
            For i = 1 To UBound(Arr, 2)
                StrSQL = StrSQL & " Union All Select #" & Arr(3, i) & "#,'" & Arr(1, 1) & "','" & Arr(2, i) & "',F1,F" & i + 1 & ",'" & Sht.Name & "' From [C$A5:E]"
            Next i
        End If
    Next Sht
    Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub

鄂龙蒙

1.rar (22.27 KB, 下载次数: 3)

2024-9-13 09:55 上传

点击文件名下载附件

limonet

代码用这个
Sub limonet()
    Dim Cn As Object, StrSQL$, Arr As Variant, Sht As Worksheet, i%
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;Hdr=No';Data Source=" & ThisWorkbook.FullName
    For Each Sht In Worksheets
        If Sht.Name <> "汇总" Then
            Arr = Intersect(Sht.Range("A1").CurrentRegion, Sht.Range("B1:H3"))
            For i = 1 To UBound(Arr, 2)
                StrSQL = StrSQL & " Union All Select #" & Arr(3, i) & "#,'" & Arr(1, 1) & "','" & Arr(2, i) & "',F1,F" & i + 1 & ",'" & Sht.Name & "' From [" & Sht.Name & "$A5:E]"
            Next i
        End If
    Next Sht
    Range("A2").CopyFromRecordset Cn.Execute(Mid(StrSQL, 12))
End Sub