[已解决]多表去重汇总到一个表里

图不安兔 · 发表于 2022-8-21 16:22

老师们：周末好！恳请帮我用VBA代码实现附件里的要求，谢谢！多谢！！！

最佳答案

哥儿-

2022-8-22 14:03

图不安兔发表于 2022-8-22 07:07
谢谢您！哥儿-老师。感谢您的辛劳！！多问一句；可否用VBA代码将“汇总”表一键生成？也就是“汇总”表起 ...

原先汇总表删除再运行代码，控件自己操作吧，附件就不上传了。
Sub 分类汇总()
Dim sh As Worksheet, arr, brr, i&, j&, num&, n&, r
Call 创建汇总表
r = Sheets("汇总").Cells(Rows.Count, 1).End(3).Row
Sheets("汇总").[c3:ab10000].ClearContents
arr = Sheets("汇总").Range("b1:ab" & r)
For i = 2 To 24 Step 2
      For Each sh In Sheets
         If sh.Name = arr(1, i) Then
            num = sh.Cells(Rows.Count, "h").End(3).Row
            brr = sh.Range("e3:h" & num)
            For j = 3 To UBound(arr)
                  If arr(j, 1) <> "" Then
                     For n = 1 To UBound(brr)
                        If brr(n, 4) = arr(j, 1) Then
                              arr(j, i) = arr(j, i) + brr(n, 1)
                              arr(j, i + 1) = arr(j, i + 1) + brr(n, 2)
                        End If
                     Next
                  End If
            Next j
         End If
      Next
Next i
For i = 3 To UBound(arr)
      For j = 2 To 24 Step 2
         arr(i, 26) = arr(i, 26) + arr(i, j)
         arr(i, 27) = arr(i, 27) + arr(i, j + 1)
      Next j
Next
Sheets("汇总").[b1].Resize(UBound(arr), UBound(arr, 2)) = arr
With Sheets("汇总").UsedRange
      .Borders.Weight = xlThin
      .Rows.AutoFit
      .Columns.AutoFit
      .HorizontalAlignment = xlCenter
End With
End Sub
Sub 创建汇总表()
Application.DisplayAlerts = False
Dim sht As Worksheet, sh As Worksheet, arr, brr, crr, i%, n%, r&, num&
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "汇总"
Set sht = ActiveSheet
With sht
      .Range("a1") = "序号": Range("a1:a2").Merge
      .Range("b1") = "供应商或顾客名": Range("b1:b2").Merge
      .Range("aa1") = "合计": Range("aa1:ab1").Merge
      .Range("aa2") = "采购": Range("ab2") = "销售"
End With
For i = 3 To 26 Step 2
      n = n + 1
      Cells(1, i).Resize(, 2).Merge
      Cells(1, i) = n & "月"
      Cells(2, i) = "采购"
      Cells(2, i + 1) = "销售"
Next i
Application.DisplayAlerts = True
Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
Dim rg As Range, rng As Range
For Each sh In Sheets
      If sh.Name <> "汇总" Then
         r = sh.Cells(Rows.Count, "h").End(3).Row
         If r < 3 Then
            GoTo 100
         Else
            Set rng = sh.Range("h3:h" & r)
            For Each rg In rng
                  If Not dic.exists(rg.Value) Then
                     num = num + 1
                     dic(rg.Value) = num
                  End If
            Next
         End If
100:    End If
Next
ReDim arr(1 To dic.Count, 1 To 2)
brr = dic.keys
crr = dic.items
For i = 0 To dic.Count - 1
      arr(i + 1, 1) = crr(i)
      arr(i + 1, 2) = brr(i)
Next
sht.[a3].Resize(UBound(arr), 2) = arr
End Sub

跳转到最佳答案楼层

哥儿- · 发表于 2022-8-21 21:53

本帖最后由哥儿- 于 2022-8-21 23:12 编辑

写好代码忘了保存，又再来了一遍，差点不想写了。文件懒得解压改格式，你自己测试一下
Sub 分类法汇总()
Dim sh As Worksheet, arr, brr, i&, j&, num&, n&, r
r = Sheets("汇总").Cells(Rows.Count, 1).End(3).Row
Sheets("汇总").[c3:ab10000].ClearContents
arr = Sheets("汇总").Range("b1:ab" & r)
For i = 2 To 24 Step 2
      For Each sh In Sheets
         If sh.Name = arr(1, i) Then
            num = sh.Cells(Rows.Count, "h").End(3).Row
            brr = sh.Range("e3:h" & num)
            For j = 3 To UBound(arr)
                  If arr(j, 1) <> "" Then
                     For n = 1 To UBound(brr)
                        If brr(n, 4) = arr(j, 1) Then
                              arr(j, i) = arr(j, i) + brr(n, 1)
                              arr(j, i + 1) = arr(j, i + 1) + brr(n, 2)
                        End If
                     Next
                  End If
            Next j
         End If
      Next
Next i
For i = 3 To UBound(arr)
      For j = 2 To 24 Step 2
         arr(i, 26) = arr(i, 26) + arr(i, j)
         arr(i, 27) = arr(i, 27) + arr(i, j + 1)
      Next j
Next
Sheets("汇总").[b1].Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub

图不安兔 · 发表于 2022-8-22 07:07

哥儿- 发表于 2022-8-21 21:53
写好代码忘了保存，又再来了一遍，差点不想写了。文件懒得解压改格式，你自己测试一下
Sub 分类法汇总()
...

谢谢您！哥儿-老师。感谢您的辛劳！！多问一句；可否用VBA代码将“汇总”表一键生成？也就是“汇总”表起初是空白一片，点击按钮即可一键生成“汇总”表。有空麻烦您给整整，谢谢！！！

哥儿- · 发表于 2022-8-22 14:03

图不安兔发表于 2022-8-22 07:07
谢谢您！哥儿-老师。感谢您的辛劳！！多问一句；可否用VBA代码将“汇总”表一键生成？也就是“汇总”表起 ...

原先汇总表删除再运行代码，控件自己操作吧，附件就不上传了。
Sub 分类汇总()
Dim sh As Worksheet, arr, brr, i&, j&, num&, n&, r
Call 创建汇总表
r = Sheets("汇总").Cells(Rows.Count, 1).End(3).Row
Sheets("汇总").[c3:ab10000].ClearContents
arr = Sheets("汇总").Range("b1:ab" & r)
For i = 2 To 24 Step 2
      For Each sh In Sheets
         If sh.Name = arr(1, i) Then
            num = sh.Cells(Rows.Count, "h").End(3).Row
            brr = sh.Range("e3:h" & num)
            For j = 3 To UBound(arr)
                  If arr(j, 1) <> "" Then
                     For n = 1 To UBound(brr)
                        If brr(n, 4) = arr(j, 1) Then
                              arr(j, i) = arr(j, i) + brr(n, 1)
                              arr(j, i + 1) = arr(j, i + 1) + brr(n, 2)
                        End If
                     Next
                  End If
            Next j
         End If
      Next
Next i
For i = 3 To UBound(arr)
      For j = 2 To 24 Step 2
         arr(i, 26) = arr(i, 26) + arr(i, j)
         arr(i, 27) = arr(i, 27) + arr(i, j + 1)
      Next j
Next
Sheets("汇总").[b1].Resize(UBound(arr), UBound(arr, 2)) = arr
With Sheets("汇总").UsedRange
      .Borders.Weight = xlThin
      .Rows.AutoFit
      .Columns.AutoFit
      .HorizontalAlignment = xlCenter
End With
End Sub
Sub 创建汇总表()
Application.DisplayAlerts = False
Dim sht As Worksheet, sh As Worksheet, arr, brr, crr, i%, n%, r&, num&
Worksheets.Add(after:=Sheets(Sheets.Count)).Name = "汇总"
Set sht = ActiveSheet
With sht
      .Range("a1") = "序号": Range("a1:a2").Merge
      .Range("b1") = "供应商或顾客名": Range("b1:b2").Merge
      .Range("aa1") = "合计": Range("aa1:ab1").Merge
      .Range("aa2") = "采购": Range("ab2") = "销售"
End With
For i = 3 To 26 Step 2
      n = n + 1
      Cells(1, i).Resize(, 2).Merge
      Cells(1, i) = n & "月"
      Cells(2, i) = "采购"
      Cells(2, i + 1) = "销售"
Next i
Application.DisplayAlerts = True
Dim dic As Object: Set dic = CreateObject("scripting.dictionary")
Dim rg As Range, rng As Range
For Each sh In Sheets
      If sh.Name <> "汇总" Then
         r = sh.Cells(Rows.Count, "h").End(3).Row
         If r < 3 Then
            GoTo 100
         Else
            Set rng = sh.Range("h3:h" & r)
            For Each rg In rng
                  If Not dic.exists(rg.Value) Then
                     num = num + 1
                     dic(rg.Value) = num
                  End If
            Next
         End If
100:    End If
Next
ReDim arr(1 To dic.Count, 1 To 2)
brr = dic.keys
crr = dic.items
For i = 0 To dic.Count - 1
      arr(i + 1, 1) = crr(i)
      arr(i + 1, 2) = brr(i)
Next
sht.[a3].Resize(UBound(arr), 2) = arr
End Sub

图不安兔 · 发表于 2022-8-22 18:40

哥儿- 发表于 2022-8-22 14:03
原先汇总表删除再运行代码，控件自己操作吧，附件就不上传了。
Sub 分类汇总()
Dim sh As Workshee ...

谢谢您！哥儿-老师。谢谢！

chen301222 · 发表于 2022-11-21 19:53

试试这个不同的写法

chen301222 · 发表于 2022-11-21 19:54

Sub 汇总()
Dim arr, brr, i, j, ws As Worksheet, x, y, s, d As Object
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
For Each ws In Sheets
If ws.Name <> "汇总" Then
      arr = ws.[a1].CurrentRegion
      For i = 3 To UBound(arr)
         If arr(i, 8) <> "" Then
            For j = 5 To 6
                  s = arr(i, 8) & "-" & arr(2, j) & "-" & ws.Name
                  d(s) = d(s) + arr(i, j)
            Next j
         End If
      Next i
End If
Next ws
With Sheets("汇总")
.UsedRange.Offset(2, 2).ClearContents
brr = .[a1].CurrentRegion
For i = 3 To UBound(brr)
      If brr(i, 2) <> "" Then
         For j = 3 To UBound(brr, 2) - 2
            If brr(1, j) = "" Then brr(1, j) = brr(1, j - 1)
            s = brr(i, 2) & "-" & brr(2, j) & "-" & brr(1, j)
            If d.exists(s) Then
                  brr(i, j) = d(s)
            End If
            If InStr(brr(2, j), "采购") > 0 Then
                  brr(i, 27) = brr(i, 27) + brr(i, j)
            Else
                  brr(i, 28) = brr(i, 28) + brr(i, j)
            End If
         Next j
      End If
Next i
.[a1].CurrentRegion = brr
End With
Application.ScreenUpdating = True
End Sub

chen301222 · 发表于 2022-11-21 20:00

试试

chen301222 · 发表于 2022-11-21 20:05

改进下多用一个字典提取名字
Sub 汇总()
Dim arr, brr, i, j, ws As Worksheet, x, y, s, d As Object
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
For Each ws In Sheets
If ws.Name <> "汇总" Then
      arr = ws.[a1].CurrentRegion
      For i = 3 To UBound(arr)
         If arr(i, 8) <> "" Then
            For j = 5 To 6
                  s = arr(i, 8) & "-" & arr(2, j) & "-" & ws.Name
                  d(s) = d(s) + arr(i, j)
                  d1(arr(i, 8)) = ""
            Next j
         End If
      Next i
End If
Next ws
With Sheets("汇总")
.UsedRange.Offset(2, 2).ClearContents
.[b3].Resize(d1.Count, 1) = Application.Transpose(d1.keys)
brr = .[a1].CurrentRegion
For i = 3 To UBound(brr)
      If brr(i, 2) <> "" Then
         For j = 3 To UBound(brr, 2) - 2
            If brr(1, j) = "" Then brr(1, j) = brr(1, j - 1)
            s = brr(i, 2) & "-" & brr(2, j) & "-" & brr(1, j)
            If d.exists(s) Then
                  brr(i, j) = d(s)
            End If
            If InStr(brr(2, j), "采购") > 0 Then
                  brr(i, 27) = brr(i, 27) + brr(i, j)
            Else
                  brr(i, 28) = brr(i, 28) + brr(i, j)
            End If
         Next j
      End If
Next i
.[a1].CurrentRegion = brr
End With
Application.ScreenUpdating = True
End Sub

kszcs · 发表于 2023-3-24 11:33

留下记号，谢谢大师

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

[已解决]多表去重汇总到一个表里

评分

评分

评分