求助按模板拆分明细，并对明细分类汇总的代码

ykcbf1100 · 发表于 2024-5-8 15:37

老丢710 发表于 2024-5-8 15:10
麻烦帮忙

改好了。。。

ykcbf1100 · 发表于 2024-5-8 15:38

按楼主要求修改

Sub ykcbf() '//2024.5.8
Dim arr, d
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim tm: tm = Timer
Set ws = ThisWorkbook
Set sh = ws.Sheets("结算表")
With ws.Sheets("供应商信息")
zrr = .UsedRange
For i = 2 To UBound(zrr)
s = zrr(i, 2)
d1(s) = i
Next
End With
bt = 1: col = 6
For Each sht In ws.Sheets
If sht.Name <> sh.Name And sht.Name <> "说明" And sht.Name <> "数据" And sht.Name <> "供应商信息" Then sht.Delete
Next
arr = ws.Sheets("数据").UsedRange
For i = bt + 1 To UBound(arr)
s = arr(i, col): ss = arr(i, 2)
If s <> Empty Then
If Not d.Exists(s) Then Set d(s) = CreateObject("scripting.dictionary")
If Not d(s).Exists(ss) Then Set d(s)(ss) = CreateObject("scripting.dictionary")
d(s)(ss)(i) = i
End If
Next i
On Error Resume Next
For Each k In d.keys
zj = 0
sh.Copy after:=ws.Sheets(ws.Sheets.Count)
Set sht = ws.Sheets(ws.Sheets.Count)
ReDim brr(1 To 30, 1 To 7)
m = 0: lc = 23
With sht
.Name = k
.[a8:g30] = ""
.[a6] = k
For x = 3 To 7
.Cells(6, x) = zrr(d1(k), x)
Next
n = 0
For Each kk In d(k).keys
Sum = 0
For Each kkk In d(k)(kk).keys
m = m + 1: n = n + 1
brr(m, 1) = n
For j = 2 To UBound(arr, 2) - 1
brr(m, j) = arr(kkk, j)
Next
Sum = Sum + brr(m, 5)
Next
m = m + 1
brr(m, 2) = kk & " 汇总": brr(m, 5) = Sum
zj = zj + Sum
Next
m = m + 1
brr(m, 2) = "总计": brr(m, 5) = zj
k = lc - m
If k > 0 Then .Rows(11 & ":" & 10 + k).Delete
If k < 0 Then
For i = 1 To m - lc
.Cells(10 + i, 1).EntireRow.Insert
Next i
End If
.[a8].Resize(m, 7) = brr
For i = 8 To 8 + m - 1
If InStr(.Cells(i, 2), "总") Then
.Cells(i, 2).Font.Bold = True
.Cells(i, 2).Font.Name = "黑体"
End If
Next
End With
Next k
ws.Sheets("数据").Activate
Set d = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "共用时：" & Format(Timer - tm) & "秒！"
End Sub

复制代码

老丢710 · 发表于 2024-5-8 16:30

感谢，我看您是对带总字的单元格字体做的设置，我是想要合计、总计行整行都加粗加黑

ykcbf1100 · 发表于 2024-5-8 16:37

老丢710 发表于 2024-5-8 16:30
感谢，我看您是对带总字的单元格字体做的设置，我是想要合计、总计行整行都加粗加黑

再改一次吧。

yanglinzi · 发表于 2024-5-8 21:53

Sub 拆分并汇总()
Dim arr, brr, i, j, r, k, n, d, d1
Dim sh As Sheets
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
With Sheets("数据")
r = .Cells(Rows.Count, 2).End(xlUp).Row
arr = .Range("a1:f" & r)
End With
brr = Sheet4.UsedRange
ReDim crr(1 To UBound(arr), 1 To 6)
For i = 2 To UBound(brr)
sa = brr(i, 2)
d1(sa) = i
Next
For j = 2 To UBound(arr)
sb = arr(j, 6)
d(sb) = d(sb) & "," & j
Next
Stop
For Each k In d.keys
If d1.exists(k) Then
Sheets("结算表").Copy After:=Sheets(Sheets.Count)
With ActiveSheet
.Name = k
.Cells(6, 1) = k
For j = 3 To 6
.Cells(6, j) = brr(d1(k), j)
Next
n = 7
xa = Split(d(k), ",")
For i = 1 To UBound(xa)
n = n + 1
.Cells(n, 1) = n - 7
For j = 2 To 5
.Cells(n, j) = arr(xa(i), j)
Next
Next
ra = .[b7].End(xlDown).Row
Set Rng = Range("b8:g" & ra)
Rng.Sort [b7], Header:=xlYes
.Cells(ra + 1, 2) = "总计"
.Cells(ra + 1, 5) = Application.Sum(Range(Cells(8, 5), Cells(ra, 5)))
For j = ra To 8 Step -1
For i = j - 1 To 7 Step -1
If Cells(j, 2) <> Cells(i, 2) Then
Rows(j + 1).Insert
Cells(j + 1, 2) = Cells(j, 2) & " " & "汇总"
Cells(j + 1, 5) = Application.Sum(Range(Cells(i + 1, 5), Cells(j, 5)))
j = i
End If
Next
Next
End With
End If
Next
End Sub

复制代码

yanglinzi · 发表于 2024-5-8 21:53

参与一下。。

wang-way · 发表于 2024-5-9 16:29

JSA 练个手

//2024-5-9
function splitData(){
let wb=ThisWorkbook;
let sht=wb.Worksheets.Item('数据');
let dt=sht.Range('a1').CurrentRegion.Value2.slice(1);
sht=wb.Worksheets.Item('供应商信息');
let pv=sht.Range('a1').CurrentRegion.Value2.slice(1);
sht=wb.Worksheets.Item('结算表');
dpv=new Set(dt.map(x=>x[5]));//供应商去重
dpv.forEach(p=>{//按供应商分类
//Debug.Print('-------------')
let f1=dt.filter(x=>x[5]==p);//筛选供应商数据
//f1=f1.sort((a,b)=>a[1].localeCompare(b[1]));//按用料单位排序
du=new Set(f1.map(x=>x[1]));//用料单位去重
let rs=[];
du.forEach(u=>{//按用料单位排序
//Debug.Print(u)
let f2=f1.filter(x=>x[1]==u);//筛选用料单位的数据
f2.forEach(f=>rs.push(f));//逐行添加数据
let sum=f2.map(x=>x[4]).reduce((a,c)=>a+c);//单位合计
rs.push(['',u+' 汇总','','',sum,'','']);//添加单位合计
});
//供应商合计
let sum=rs.map(x=>x[4]).reduce((a,c)=>a+c);
rs.push(['','合计','','',sum,'','']);
//修改序号
let i=1;
rs.forEach(r=> {if(!isNaN(r[0]) && typeof r[0] === "number") r[0]=i++});
try{
nsht=wb.Worksheets.Item(p); //连接表
}catch{
sht.Copy(before=wb.Worksheets.Item(1));//复制模板表
nsht=wb.Worksheets.Item(1); //连接表
nsht.Name=p;//命名
}
nsht.Range('a8').Resize(rs.length,rs[0].length).Value2=rs;//输出数据
let h=pv.filter(v=>v[1]==p);//筛选供应商数据
if(h.length>0){
h[0][0]=h[0][1];
nsht.Range('a6').Resize(h.length,h[0].length).Value2=h;//输出供应商数据
}else{
//无供应商数据
}
})
}

复制代码

老丢710 · 发表于 2024-5-10 19:13

本帖最后由老丢710 于 2024-5-11 15:20 编辑

ykcbf1100 发表于 2024-5-8 16:37
再改一次吧。

感谢大神！已可以完美解决问题，再请教一下，如果更换类似模块，按使用单位拆分（模板会有微调），需要修改那些语句？

老丢710 · 发表于 2024-5-10 19:20

本帖最后由老丢710 于 2024-5-11 15:19 编辑

ykcbf1100 发表于 2024-5-8 16:37
再改一次吧。

大神换了个模板，烦请修改一个代码

老丢710 · 发表于 2024-5-11 15:17

ykcbf1100大神，换了个模板，能帮忙修改一下代码吗？

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

[求助] 求助按模板拆分明细，并对明细分类汇总的代码