原先汇总表删除再运行代码,控件自己操作吧,附件就不上传了。
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