有偿求助，一包芙蓉王

ykcbf1100 · 发表于 2024-5-21 11:16

参与一下。。。

Sub ykcbf() '//2024.5.21
Dim arr, d
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
With Sheets("数据来源")
r = .Cells(.Rows.Count, "a").End(xlUp).Row
arr = .[a1].Resize(r, 12)
End With
ReDim brr(1 To 10000, 1 To UBound(arr, 2))
For i = 1 To UBound(arr)
s = CStr(arr(i, 4))
If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
d(s)(i) = i
Next
b = [{1,2,3,4,5,6,7,9,10,11,12}]
bb = [{4,5,6,7,11}]
On Error Resume Next
For Each k In d.keys
ReDim Sum(1 To 2)
For Each kk In d(k).keys
m = m + 1
For j = 1 To UBound(b)
brr(m, j) = arr(kk, b(j))
Next
Sum(1) = Sum(1) + brr(m, 8)
Sum(2) = Sum(2) + brr(m, 9)
Next
m = m + 1
brr(m, 1) = "合计"
For x = 1 To UBound(bb)
brr(m, bb(x)) = brr(m - 1, bb(x))
Next
brr(m, 8) = Sum(1)
brr(m, 9) = Sum(2)
Next
With Sheets("VBA结果")
.UsedRange.Cells.Interior.ColorIndex = 0
.Columns(4).NumberFormatLocal = "@"
.[a2].Resize(m, 11) = brr
For i = 2 To m + 1
If .Cells(i, 1) = "合计" Then
.Cells(i, 1).Resize(1, 11).Cells.Interior.ColorIndex = 6
End If
Next
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

张起灵1 · 发表于 2024-5-21 11:22

已解决

LIUZHU · 发表于 2024-5-21 11:29

原始数据多了一列空白的，我删了，效果如下

LIUZHU · 发表于 2024-5-21 11:30

JSA代码，可以适合你的WPS软件

function 数据整理(){
let arr=Sheets.Item("数据来源").Range("a1").CurrentRegion.Value2;
let dic={},k=0;
let obj=arr.reduce((obj,x)=>{
dic[x[5]]=dic[x[5]] || ++k;
let temp=obj[x[5]]=obj[x[5]] || ["合计",,,x[3],x[4],x[5],x[6],0,0,,x[10]];
[7,8].forEach(y=>temp[7]+=x[7]); //求和
return obj;
},{});
arr.push(...Object.values(obj));
arr.sort((a,b)=>dic[a[5]]-dic[b[5]]);
Sheets.Item("JSA结果").Activate();
Cells.Clear();
Range("a1").Resize(arr.length,arr[0].length).Value2=arr;
Range("a1").CurrentRegion.EntireColumn.AutoFit();
[...Range("a1").CurrentRegion.Columns(1).Cells].forEach((rng,i)=>{
if (rng.Value2=="合计") [rng.EntireRow.Interior.ColorIndex, rng.EntireRow.Font.Bold]=[33, true];
});
}

复制代码

LIUZHU · 发表于 2024-5-21 11:30

附件在此，请审核效果

micch · 发表于 2024-5-21 11:36

Sub Test()
Dim d As Object, i As Long
Set d = CreateObject("scripting.dictionary")
d.CompareMode = vbTextCompare
ar = Sheet1.UsedRange.Value
ReDim br(1 To UBound(ar) * 2, 1 To UBound(ar, 2))
For i = 1 To UBound(ar)
If i > 1 Then
If ar(i, 4) <> ar(i - 1, 4) Or i = UBound(ar) Then
j = j + 1
br(j, 1) = "合计"
For k = 4 To 7
br(j, k) = br(j - 1, k)
Next
br(j, 8) = s1
br(j, 9) = s2
br(j, 10) = br(j - 1, 10)
br(j, 11) = br(j - 1, 11)
s1 = 0
s2 = 0
End If
End If
j = j + 1
For k = 1 To UBound(ar, 2) - 1
br(j, k) = ar(i, IIf(k < 10, k, k + 1))
Next
s1 = s1 + ar(i, 8)
s2 = s2 + ar(i, 9)
Next
With Sheet3
.Cells.ClearContents
.Cells.Interior.Color = xlNone
.Cells.Font.Bold = False
.Range("a2").Resize(j, UBound(ar, 2)).Value = br
For i = 2 To j + 1
If br(i - 1, 1) = "合计" Then
.Cells(i, 1).Resize(1, UBound(ar, 2)).Interior.Color = &HF0B000
.Cells(i, 1).Resize(1, UBound(ar, 2)).Font.Bold = True
End If
Next
End With
End Sub

复制代码

3190496160 · 发表于 2024-5-21 11:43

Sub 分类小计()
Application.ScreenUpdating = False
Dim ar As Variant
Dim d As Object, dc As Object
Set d = CreateObject("scripting.dictionary")
With Sheets("数据来源")
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:l" & r)
End With
Dim br()
For i = 1 To UBound(ar)
If ar(i, 1) <> "" Then
      zd = ar(i, 4) & "|" & ar(i, 5) & "|" & ar(i, 6) & "|" & ar(i, 7)
      If Not d.exists(zd) Then Set d(zd) = CreateObject("scripting.dictionary")
      d(zd)(i) = i
End If
Next i
With Sheets("VBA结果")
.UsedRange.Font.Bold = False
.UsedRange.Interior.ColorIndex = 0
.UsedRange = Empty
For Each k In d.keys
      n = 0
      ReDim br(1 To UBound(ar), 1 To 11)
      For Each kk In d(k).keys
         xh = kk
         If ar(xh, 2) <> "" Then
            n = n + 1
            For j = 1 To 7
                  br(n, j) = ar(xh, j)
            Next j
            For j = 9 To 12
                  br(n, j - 1) = ar(xh, j)
            Next j
         End If
      Next kk
      n = n + 1
      br(n, 1) = "合计"
      For j = 4 To 7
         br(n, j) = br(n - 1, j)
      Next j
      br(n, 11) = br(n - 1, 11)
      rs = .Cells(Rows.Count, 1).End(xlUp).Row + 1
      .Cells(rs, 1).Resize(n, UBound(br, 2)) = br
      For j = 8 To 9
         .Cells(rs + n - 1, j) = Application.Sum(Application.Index(br, 0, j))
      Next j
      With .Cells(rs + n - 1, 1).Resize(1, 11)
         .Interior.ColorIndex = 33
         .Font.Bold = True
      End With
Next k
End With
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-5-21 11:45

测试20240521.rar (22.21 KB, 下载次数: 14)

wang-way · 发表于 2024-5-21 13:13

JSA 练手

//JSA 012 分类插入合计行
function subtotal1(){
var wb=ThisWorkbook;
var sht=wb.Worksheets.Item('数据来源');
var ar=sht.Range('a1').CurrentRegion.Value();
keys=new Set(ar.map(r=>r[3]));//D列编码去重
br=[];
for(k of keys)
{
//console.log(k)
t=ar.filter(r=>r[3]==k);//筛选D列编码相同的数据行
t.forEach(r=>br.push(r));//存入数组
//构建合计行
x=['合计','','',t[0][3],t[0][4],t[0][5],t[0][6],0,0,'',t[0][10]];
console.log(...x,"////")
x[7]=t.reduce((a,c)=>a+c[7],0);//H合计
x[8]=t.reduce((a,c)=>a+c[8],0);//I合计
//追加合计行
br.push(x);
}
var sht=wb.Worksheets.Item('VBA结果');
var ar=sht.Range('a1').Resize(br.length,br[0].length).Value2=br;
}

复制代码

LIUZHU · 发表于 2024-5-21 14:23

wang-way 发表于 2024-5-21 13:13
JSA 练手

数组的filter方法好像效率挺低的

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

[求助] 有偿求助，一包芙蓉王