汇总

ddz79101

老师，有3张表，我希望能按月列名连续放置于1表，结果见合汇表。请老师帮忙指导

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.2.28
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set Sh = ThisWorkbook.Sheets("合汇")
   
6.     For Each Sht In Sheets
   
7.         If Sht.Name <> Sh.Name Then
   
8.             With Sht
   
9.                 r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
10.                 arr = .[a1].Resize(r, 8)
    
11.             End With
    
12.             For i = 2 To UBound(arr)
    
13.                 For j = 2 To UBound(arr, 2)
    
14.                     s = arr(i, 1) & "|" & arr(1, j)
    
15.                     d(s) = arr(i, j)
    
16.                 Next
    
17.             Next
    
18.         End If
    
19.     Next
    
20.     With Sh
    
21.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
    
22.         arr = .[a1].Resize(r, 22)
    
23.         For i = 3 To UBound(arr)
    
24.             For j = 2 To UBound(arr, 2)
    
25.                 s = arr(i, 1) & "|" & arr(2, j)
    
26.                 If d.Exists(s) Then
    
27.                     arr(i, j) = d(s)
    
28.                 Else
    
29.                     arr(i, j) = ""
    
30.                 End If
    
31.             Next
    
32.         Next
    
33.         .[a1].Resize(r, 22) = arr
    
34.     End With
    
35.     Set d = Nothing
    
36.     Application.ScreenUpdating = True
    
37.     MsgBox "OK！"
    
38. End Sub
    
39. 
    

复制代码

fzxba

1. Sub test0() '自动生成,数据格式一致,可纯用数组来写
   
2.   
   
3.   Dim ar(), br(), Dict As Object, Target As Range
   
4.   Dim i As Long, j As Long, k As Long, p As Long
   
5.   Dim m As Integer, Col As Long, sKey As String
   
6.   
   
7.   Set Target = Range("A1")
   
8.   Target.CurrentRegion.Clear
   
9.   
   
10.   Application.ScreenUpdating = False
    
11.   
    
12.   Set Dict = CreateObject("Scripting.Dictionary")
    
13.   ReDim ar(1 To Worksheets.Count - 1)
    
14.   
    
15.   Col = 1
    
16.   m = 7            '从  7月 始
    
17.   For i = m To 12  '到 12月 止
    
18.     If i = m Then
    
19.       For j = 1 To UBound(ar)
    
20.         ar(j) = Worksheets(j).Range("A1").CurrentRegion.Value
    
21.         If j = 1 Then ReDim br(1 To UBound(ar(j)) + 1, 1 To UBound(ar(j), 2) * 12)
    
22.       Next
    
23.     End If
    
24.     p = 2 + (i - m) * 3
    
25.     br(1, p) = i & "月"
    
26.     Target.Offset(, p - 1).Resize(, 3).HorizontalAlignment = xlCenterAcrossSelection
    
27.     For j = 1 To UBound(ar)
    
28.       Col = Col + 1
    
29.       br(2, Col) = i & Left(Worksheets(j).Name, 1)
    
30.       Dict.Add br(2, Col), Col
    
31.     Next
    
32.   Next
    
33.   p = 2 + (i - m) * 3
    
34.   br(1, p) = "合计"
    
35.   Target.Offset(, p - 1).Resize(, 3).HorizontalAlignment = xlCenterAcrossSelection
    
36.   For j = 1 To Worksheets.Count - 1
    
37.     Col = Col + 1
    
38.     Dict.Add Worksheets(j).Name & "年支出", Col
    
39.     br(2, Col) = Left(Worksheets(j).Name, 1) & "年支出"
    
40.   Next
    
41.   
    
42.   For k = 1 To UBound(ar)
    
43.     If k = 1 Then
    
44.       For i = 1 To UBound(ar(k))
    
45.         br(i + 1, 1) = ar(k)(i, 1)
    
46.       Next
    
47.     End If
    
48.     For j = 2 To UBound(ar(k), 2)
    
49.       If j < UBound(ar(k), 2) Then sKey = ar(k)(1, j) Else sKey = Worksheets(k).Name & ar(k)(1, j)
    
50.       p = Dict(sKey)
    
51.       If p Then
    
52.         For i = 2 To UBound(ar(k))
    
53.           br(i + 1, p) = ar(k)(i, j)
    
54.         Next
    
55.       End If
    
56.     Next
    
57.   Next
    
58.   
    
59.   With Target.Resize(UBound(br), Col)
    
60.     .Borders.LineStyle = xlContinuous
    
61.     With Intersect(.Offset(0), .Offset(1))
    
62.       .HorizontalAlignment = xlCenter
    
63.       .Font.Size = 10
    
64.     End With
    
65.     .Value = br
    
66.     .Cells(1).Resize(2).Merge
    
67.   End With
    
68.   
    
69.   Set Dict = Nothing
    
70.   Set Target = Nothing
    
71.   Application.ScreenUpdating = True
    
72.   Beep
    
73. End Sub

复制代码

fzxba

数组_供参考.zip (24.14 KB, 下载次数: 25)

2024-2-28 18:21 上传

点击文件名下载附件

ddz79101

ykcbf1100 发表于 2024-2-28 17:06
附件供参考。。。

谢谢老师！代码运行结果显示，表格是搬到一张表里了，但有2个问题：1，行首名和列首名能否不预设；2，是合计数有问题，因为都一样值了。

ddz79101

fzxba 发表于 2024-2-28 18:21

谢谢老师！代码结果正确，成功！但是我将老师的代码放在工作簿中有多表情况下，对此3表进行汇总，我修改老师的代码 ReDim ar(1 To Worksheets.Count - 1)和For j = 1 To UBound(ar)，未成功。老师，帮忙看看吗，或告知我修改哪里，或用其它遍览代码替代吗？

ykcbf1100

ddz79101 发表于 2024-2-28 18:44
谢谢老师！代码运行结果显示，表格是搬到一张表里了，但有2个问题：1，行首名和列首名能否不预设；2，是 ...

标题能自动生成，但需要更多代码。合计也能自动生成。
有时间再更新一下吧。

ddz79101

ykcbf1100 发表于 2024-2-28 19:18
标题能自动生成，但需要更多代码。合计也能自动生成。
有时间再更新一下吧。

谢谢！我知道。我只是想能否一气呵成，

ykcbf1100

ddz79101 发表于 2024-2-28 19:23
谢谢！我知道。我只是想能否一气呵成，

下次求助时一次性说清楚啊，代码写法都不同的，我得推倒重写了。