多个表格其中一项不能汇总，求帮助

wzd028 · 发表于 2024-8-2 11:37

打开“计划汇总表”，运行VBA后“计划汇总表”只能汇总一个部门的“用途”文字，如何把各部门“用途”的文字一起汇总到“计划汇总表”。
1、要求按H2至N2顺序把各部门“用途”文字汇总到单元格，并且用“；”分割开，见附图。
2、其他VBA不要更改。

汇总.rar (282.31 KB, 下载次数: 8)

捕获.JPG

ykcbf1100 · 发表于 2024-8-2 16:01

原代码是我写的吧。

ykcbf1100 · 发表于 2024-8-2 16:10

附件供参考。。。

这个原代码应该是前几年写的。

ykcbf1100 · 发表于 2024-8-2 16:10

代码更新一下。。。

Sub 各部门汇总数据()
Dim arr, brr, d, p, f
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
b = [{2,3,4,5,6,12,10}]
Set sh = ThisWorkbook.Sheets("采购计划表")
c = sh.UsedRange.Find("*预计月度用量合计*", , , , , 1).Column
p = ThisWorkbook.Path & "" '//文件路径
f = Dir(p & "*.xls*") '//文件名
Do While f <> ""
If f <> ThisWorkbook.Name Then
fn = Split(Split(f, ".")(0), "（")(1)
fn = Left(fn, Len(fn) - 1)
With Workbooks.Open(p & f, 0)
With .Sheets(1)
r = .Cells(.Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 13)
End With
.Close False
End With
For i = 3 To UBound(arr)
s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
If s <> Empty Then
If Not d.Exists(s) Then
d(s) = Array(arr(i, 2), arr(i, 3), arr(i, 4), arr(i, 5), arr(i, 6), arr(i, 12))
Else
t = d(s)
t(5) = IIf(InStr(t(5), arr(i, 12)), t(5), t(5) & "；" & arr(i, 12))
d(s) = t
End If
d1(s & "|" & fn) = d1(s & "|" & fn) + arr(i, 10)
End If
Next
End If
f = Dir
Loop
On Error Resume Next
ReDim brr(1 To d.Count, 1 To 7)
For Each k In d.keys
m = m + 1
brr(m, 1) = m
t = d(k)
For x = 0 To d.Count - 1
brr(m, x + 2) = t(x)
Next
Next
With sh
.UsedRange.Offset(3).ClearContents
.[a4].Resize(m, 7) = brr
.[a4].Resize(m, c).Borders.LineStyle = 1
arr = .UsedRange
For i = 4 To UBound(arr)
Sum = 0
For j = 8 To c - 1
s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(2, j)
If s <> Empty Then
If d1.Exists(s) Then
arr(i, j) = d1(s)
Sum = Sum + arr(i, j)
End If
End If
Next
arr(i, c) = Sum
Next
.UsedRange = arr
ActiveWindow.DisplayZeros = False
End With
Application.ScreenUpdating = True
MsgBox "运行完毕，共用时： " & Format(Timer - tm) & "秒！"
End Sub

复制代码

ykcbf1100 · 发表于 2024-8-2 19:07

本帖最后由 ykcbf1100 于 2024-8-2 19:10 编辑

换个写法。
这个就是我现在的写法。

ykcbf1100 · 发表于 2024-8-2 19:10

换个写法。

Sub ykcbf() '//2024.8.2 按部门汇总
Dim arr, brr, d, p, f
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
b = [{1,2,3,4,5,6,12}]
Set sh = ThisWorkbook.Sheets("采购计划表")
c = sh.UsedRange.Find("*预计月度用量合计*", , , , , 1).Column
p = ThisWorkbook.Path & ""
ReDim brr(1 To 10000, 1 To 15)
On Error Resume Next
For Each f In fso.GetFolder(p).Files
If LCase$(f.Name) Like "*.xls*" Then
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
fn = Split(fso.GetBaseName(f), "（")(1)
fn = Left(fn, Len(fn) - 1)
Set wb = Workbooks.Open(f, 0)
With wb.Sheets("月度使用计划表")
r = .Cells(.Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 13)
End With
wb.Close False
For i = 3 To UBound(arr)
s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
If s <> Empty Then
If Not d.Exists(s) Then
m = m + 1
d(s) = m
brr(m, 1) = m
For j = 2 To UBound(b)
brr(m, j) = arr(i, b(j))
Next
brr(m, 15) = arr(i, 10)
Else
r = d(s)
brr(r, 7) = IIf(InStr(brr(r, 7), arr(i, 12)), brr(r, 7), brr(r, 7) & "；" & arr(i, 12))
brr(r, 15) = brr(r, 15) + arr(i, 10)
End If
d1(s & "|" & fn) = d1(s & "|" & fn) + arr(i, 10)
End If
Next
End If
End If
Next
With sh
.UsedRange.Offset(3).ClearContents
.[a4].Resize(m, 15) = brr
.[a4].Resize(m, c).Borders.LineStyle = 1
arr = .UsedRange
For i = 4 To UBound(arr)
For j = 8 To c - 1
s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(2, j)
If s <> Empty Then
If d1.Exists(s) Then
arr(i, j) = d1(s)
End If
End If
Next
Next
.UsedRange = arr
ActiveWindow.DisplayZeros = False
End With
Application.ScreenUpdating = True
MsgBox "运行完毕，共用时： " & Format(Timer - tm) & "秒！"
End Sub

复制代码

wzd028 · 发表于 2024-8-2 22:24

ykcbf1100 发表于 2024-8-2 16:10
附件供参考。。。

这个原代码应该是前几年写的。

再次感谢老师的帮助，由于疏忽没有写清楚，能否把各部门名称（根据各部门使用计划表带括号的部门名称）添加到“计划汇总表”的“用途”里面，如：医养服务部：用于更换遥控器；后勤组：计算器用；社工部：KTV室用、其它活动用；膳食组：电子钟用。请用3楼你编写VBA表格（此表格如果要添加部门后可以运行VBA汇总数据，不需要修改VBA），谢谢！

wzd028 · 发表于 2024-8-2 22:35

ykcbf1100 发表于 2024-8-2 19:07
换个写法。
这个就是我现在的写法。

汇总表如果增加部门后“预计月度用量合计”不能汇总同一个物品各部门的数量。

ykcbf1100 · 发表于 2024-8-3 14:41

wzd028 发表于 2024-8-2 22:24
再次感谢老师的帮助，由于疏忽没有写清楚，能否把各部门名称（根据各部门使用计划表带括号的部门名称）添 ...

改好了。

汇总我看了下应该没问题。

ykcbf1100 · 发表于 2024-8-3 14:43

代码供参考。。。

Sub ykcbf() '//2024.8.3 按部门汇总
Dim arr, brr, d, p, f
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set fso = CreateObject("Scripting.FileSystemObject")
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
b = [{1,2,3,4,5,6,12}]
Set sh = ThisWorkbook.Sheets("采购计划表")
c = sh.UsedRange.Find("*预计月度用量合计*", , , , , 1).Column
p = ThisWorkbook.Path & ""
ReDim brr(1 To 10000, 1 To 15)
On Error Resume Next
For Each f In fso.GetFolder(p).Files
If LCase$(f.Name) Like "*.xls*" Then
If InStr(f.Name, ThisWorkbook.Name) = 0 Then
fn = Split(fso.GetBaseName(f), "（")(1)
fn = Left(fn, Len(fn) - 1)
Set wb = Workbooks.Open(f, 0)
With wb.Sheets("月度使用计划表")
r = .Cells(.Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 13)
End With
wb.Close False
For i = 3 To UBound(arr)
s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4)
If s <> Empty Then
If Not d.Exists(s) Then
m = m + 1
d(s) = m
brr(m, 1) = m
For j = 2 To UBound(b) - 1
brr(m, j) = arr(i, b(j))
Next
brr(m, 7) = fn & "：" & arr(i, 12)
brr(m, 15) = arr(i, 10)
Else
r = d(s)
brr(r, 7) = IIf(InStr(brr(r, 7), fn & "：" & arr(i, 12)), brr(r, 7), brr(r, 7) & "；" & fn & "：" & arr(i, 12))
brr(r, 15) = brr(r, 15) + arr(i, 10)
End If
d1(s & "|" & fn) = d1(s & "|" & fn) + arr(i, 10)
End If
Next
End If
End If
Next
With sh
.UsedRange.Offset(3).ClearContents
.[a4].Resize(m, 15) = brr
.[a4].Resize(m, c).Borders.LineStyle = 1
arr = .UsedRange
For i = 4 To UBound(arr)
For j = 8 To c - 1
s = arr(i, 2) & "|" & arr(i, 3) & "|" & arr(i, 4) & "|" & arr(2, j)
If s <> Empty Then
If d1.Exists(s) Then
arr(i, j) = d1(s)
End If
End If
Next
Next
.UsedRange = arr
ActiveWindow.DisplayZeros = False
End With
Application.ScreenUpdating = True
MsgBox "运行完毕，共用时： " & Format(Timer - tm) & "秒！"
End Sub

复制代码

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

[求助] 多个表格其中一项不能汇总，求帮助