汇总

ddz79101 · 发表于 2024-2-28 20:15

ykcbf1100 发表于 2024-2-28 19:24
下次求助时一次性说清楚啊，代码写法都不同的，我得推倒重写了。

谢谢指出我的语言缺点，我犯了意思不一气呵成的错误。

chxw68 · 发表于 2024-2-28 21:07

Sub test()
Dim r%, i%
Dim arr, brr, bt()
Dim d As Object
Dim ws As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
For Each ws In Worksheets
If ws.Name <> "合汇" Then
With ws
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(1, c)
For j = 2 To UBound(arr, 2)
If arr(1, j) = "年支出" Then
xm1 = "合计"
xm2 = .Name
Else
xm1 = Val(arr(1, j))
xm2 = arr(1, j)
End If
If Not d1.exists(xm1) Then
Set d1(xm1) = CreateObject("scripting.dictionary")
End If
d1(xm1)(xm2) = Empty
Next
End With
End If
Next
n = 1
For Each aa In d1.keys
For Each bb In d1(aa).keys
n = n + 1
d1(aa)(bb) = n
Next
Next
ls = n
For Each ws In Worksheets
If ws.Name <> "合汇" Then
With ws
r = .Cells(.Rows.Count, 1).End(xlUp).Row
c = .Cells(1, .Columns.Count).End(xlToLeft).Column
arr = .Range("a1").Resize(r, c)
For i = 2 To UBound(arr)
If Not d.exists(arr(i, 1)) Then
ReDim brr(1 To ls)
brr(1) = arr(i, 1)
Else
brr = d(arr(i, 1))
End If
For j = 2 To UBound(arr, 2)
If arr(1, j) = "年支出" Then
xm1 = "合计"
xm2 = .Name
Else
xm1 = Val(arr(1, j))
xm2 = arr(1, j)
End If
n = d1(xm1)(xm2)
brr(n) = arr(i, j)
Next
d(arr(i, 1)) = brr
Next
End With
End If
Next
ReDim crr(1 To d.Count, 1 To ls)
m = 0
For Each aa In d.keys
brr = d(aa)
m = m + 1
For j = 1 To UBound(brr)
crr(m, j) = brr(j)
Next
Next
With Worksheets("合汇")
.Cells.Clear
With .Range("a1")
.Value = "户名"
.Resize(2, 1).Merge
End With
n = 2
For Each aa In d1.keys
With .Cells(1, n)
.Value = aa
.Resize(1, d1(aa).Count).Merge
If aa <> "合计" Then
.NumberFormatLocal = "0月"
End If
End With
For Each bb In d1(aa).keys
.Cells(2, n) = bb
n = n + 1
Next
Next
.Range("a3").Resize(UBound(crr), UBound(crr, 2)) = crr
With .Range("a1").Resize(2 + UBound(crr), UBound(crr, 2))
.Borders.LineStyle = xlContinuous
With .Font
.Name = "微软雅黑"
.Size = 11
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End With
End Sub

复制代码

chxw68 · 发表于 2024-2-28 21:08

按楼主要求一气呵成。

yynrzwh · 发表于 2024-2-28 21:12

汇总.zip (24.39 KB, 下载次数: 8)

ddz79101 · 发表于 2024-2-28 21:40

chxw68 发表于 2024-2-28 21:08
按楼主要求一气呵成。

谢谢老师！成功运行！遥遥领先！

ddz79101 · 发表于 2024-2-28 21:41

yynrzwh 发表于 2024-2-28 21:12

谢谢老师！成功运行！一马当先

fzxba · 发表于 2024-2-29 08:04

本帖最后由 fzxba 于 2024-2-29 11:41 编辑

ddz79101 发表于 2024-2-28 19:17
谢谢老师！代码结果正确，成功！但是我将老师的代码放在工作簿中有多表情况下，对此3表进行汇总，我修改 ...

调整见附件这论坛的审核太长了.zip (24.61 KB, 下载次数: 6)

这是新补的，供测试

附件工作表乱调整纯数组再写一个补传.zip (25.17 KB, 下载次数: 14)

ddz79101 · 发表于 2024-2-29 14:21

fzxba 发表于 2024-2-29 08:04
这是新补的，供测试

谢谢老师！运行成功！列释详细，还给了另方法代码

fzxba · 发表于 2024-2-29 14:42

ddz79101 发表于 2024-2-29 14:21
谢谢老师！运行成功！列释详细，还给了另方法代码

		自动登录	找回密码
密码			免费注册

[求助] 汇总

评分

评分

评分