如何对表格区域进行二维交互表转换成一维表并进行汇总统计

星梦月缘

老师好，我现在有5个工作表，前四个工作表都是二维交互数据表，结构都是一样的，现在我想在第5个汇总表中对前4个表中的数据进行转换成一维表，并进行汇总统计。效果图如下面图片所示，示例文件已上传，麻烦老师，有空了帮忙看下，非常感谢。

shiruiqiang

sub test          '附件下载不了,盲打

dim arr,brr
dim dic
dim sht as worksheet
set dic=createobject("scripting.dictionary")
for each sht in sheets
if  sht.name <>"汇总" then
    arr=sht.[a1].currentregion
    for x=2 to ubound(arr)
    for y=2 to ubound(arr,2)
    dic(arr(x,1) &"|"&arr(1,y)&"|" & sht.name &"表中的数值")=arr(x,y)
    next
    next
endif
next
brr=sheets("汇总").[a1].currentregion
for i=2 to ubound(brr)
for j=2 to ubound(brr,2)
if dic.exists(brr(i,1)&"|"&brr(i,2)&"|"&brr(1,j)) then
brr(i,j)=dic(brr(i,1)&"|"&brr(i,2)&"|"&brr(1,j))
endif
next
next
sheets("汇总").[a1].currentregion=brr
msgbox "ok"
end sub

ykcbf1100

参与一下。。。

1. Sub 多工作表汇总()                 '//不限工作表,2024.1.20
   
2.     Dim tm: tm = Timer
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("Scripting.Dictionary")
   
6.     Set sh = Sheets("汇总")
   
7.     sh.Range("a2:f10000").ClearContents
   
8.     For Each sht In Worksheets
   
9.         If sht.Name <> sh.Name Then
   
10.             With sht
    
11.                 r = .Cells(Rows.Count, 1).End(3).Row
    
12.                 arr = .Range("a1:m" & r)
    
13.                 fn = .Name
    
14.             End With
    
15.             For i = 2 To UBound(arr)
    
16.                 For j = 2 To UBound(arr, 2)
    
17.                     s = arr(i, 1) & "|" & arr(1, j) & "|" & fn
    
18.                     d(s) = d(s) + arr(i, j)
    
19.                 Next
    
20.             Next
    
21.         End If
    
22.     Next
    
23.     With sh
    
24.         r = .Cells(Rows.Count, 1).End(3).Row
    
25.         arr = .Range("a1:f" & r)
    
26.         For i = 2 To UBound(arr)
    
27.             For j = 3 To UBound(arr, 2)
    
28.                 s = arr(i, 1) & "|" & arr(i, 2) & "|" & Replace(arr(1, j), "表中的数值", "")
    
29.                 If d.exists(s) Then
    
30.                     arr = d(s)
    
31.                 Next
    
32.             Next
    
33.         Next
    
34.          .Range("a1:f" & r) = arr
    
35.     End With
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "汇总完毕，共用时： " & Format(Timer - tm, "0.000秒"), , "提示"
    
38. End Sub
    

复制代码

ykcbf1100

附件无法下载，上个图吧。

星梦月缘

不好意思  老师  附件重新上传下表  

ykcbf1100

星梦月缘 发表于 2024-1-20 21:22
不好意思  老师  附件重新上传下表

附件供参考。。。

limonet

关键字：Union all+left join

limonet

Sub limonet()
    Dim StrSQL$, StrSQL1$, Cn As Object, i%, Sht As Worksheet
    Set Cn = CreateObject("ADODB.connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL1 = "Select * From [汇总$A:B]"
    For Each Sht In Worksheets
        If Sht.Name <> "汇总" Then
            For i = 2 To 13
                StrSQL = StrSQL & " Union ALL Select 部门,'" & Sht.Cells(1, i) & "' as 项目," & Sht.Cells(1, i) & " as 值 From [" & Sht.Name & "$A:M]"
            Next i
            StrSQL1 = "Select a.*,b.值 From (" & StrSQL1 & ")a Left Join (" & Mid(StrSQL, 12) & ")b On a.部门=b.部门 And a.项目=b.项目"
            StrSQL = ""
        End If
    Next Sht
    Sheet5.Range("A2").CopyFromRecordset Cn.Execute(StrSQL1)
End Sub

星梦月缘

ykcbf1100 发表于 2024-1-20 21:42
附件供参考。。。

首先谢谢老师的帮助，希望老师有空了能再完善下表，我描述的时候可能没描述清楚，汇总表中 AB列的内容也是需要自动生成的。汇总表中只有表头的内容，其他内容都是空的，希望点过汇总之后，自动生成部门，项目 和对应的统计数值，非常感谢。

wxxydl

我也参与一下。。。