如何利用VBA求和？

mymotoe6

如题，如何利用VBA求和，同时解释一下，谢谢！

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, dic As Object, strKey$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        strKey = ar(i, 3) & "," & Mid(ar(i, 4), 8, 1)
        dic(strKey) = dic(strKey) + ar(i, UBound(ar, 2))
    Next i
   
    With [K1].CurrentRegion
        .Offset(1, 1).ClearContents
        ar = .Value
        For i = 2 To UBound(ar)
             For j = 2 To UBound(ar, 2) - 1
                 strKey = ar(i, 1) & "," & ar(1, j)
                 ar(i, j) = dic(strKey)
                 ar(i, UBound(ar, 2)) = ar(i, UBound(ar, 2)) + ar(i, j)
             Next j
        Next i
        .Value = ar
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

请参考附件。。。

limonet

关键字：union all+group by+pivot

limonet

Sub limont()
    Dim Cn As Object, StrSQL$
    Set Cn = CreateObject("Adodb.Connection")
    Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
    StrSQL = "Select 形名,mid(批次No,8,1) as W,投入数 From [TJ100$A:G] Where 投入数>0 Union All Select 形名,'合计',Sum(投入数) From [TJ100$A:G] Where 投入数>0 Group By 形名"
    StrSQL = "TransForm Sum(投入数) Select 形名 From (" & StrSQL & ") Group By 形名 Pivot W"
    Range("k2").CopyFromRecordset Cn.Execute(StrSQL)
End Sub

ykcbf1100

结果表自动生成。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024.4.16
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Cells(Rows.Count, 1).End(3).Row
   
4.     arr = [a1].Resize(r, 8)
   
5.     ReDim brr(1 To UBound(arr), 1 To 9)
   
6.     m = 1: n = 1
   
7.     brr(1, 1) = "TYPE": brr(1, 9) = "合计"
   
8.     On Error Resume Next
   
9.     For i = 2 To UBound(arr)
   
10.         s = arr(i, 3)
    
11.         If Not d.exists(s) Then
    
12.             m = m + 1
    
13.             d(s) = m
    
14.             brr(m, 1) = s
    
15.             brr(m, 9) = 0
    
16.         End If
    
17.         s = Mid(arr(i, 4), 8, 1)
    
18.         If Not d.exists(s) Then
    
19.             n = n + 1
    
20.             d(s) = n
    
21.             brr(1, n) = s
    
22.         End If
    
23.         r = d(arr(i, 3)): c = d(Mid(arr(i, 4), 8, 1))
    
24.         brr(r, c) = brr(r, c) + arr(i, 7)
    
25.     Next
    
26.     For i = 2 To UBound(brr)
    
27.         brr(i, 9) = 0
    
28.         For j = 2 To UBound(brr, 2) - 1
    
29.             brr(i, 9) = brr(i, 9) + brr(i, j)
    
30.         Next
    
31.     Next
    
32.     [k1:s8].Clear
    
33.     [k1].Resize(m, 9) = brr
    
34.     [k1].Resize(m, 9).Borders.LineStyle = 1
    
35.     Set d = Nothing
    
36.     MsgBox "OK！"
    
37. End Sub
    

复制代码

mymotoe6

感谢大家，感谢万分

LIUZHU

JSA代码

1. function 统计(){
   
2.         let obj=Range("a2:g19").Value2.reduce((dic,[,,a,b,,,c])=>{
   
3.                 let temp=dic[a]=dic[a] || [a,0,0,0,0,0,0,0,"=SUM(RC[-7]:RC[-1])"];
   
4.                 let n=dic.表头.indexOf(Number(b.slice(7,8)));
   
5.                 temp[n]+=c;
   
6.                 return dic;
   
7.         },{"表头":["TYPE",1,2,3,4,5,6,7,"合计"]});
   
8.         let res=Object.values(obj);
   
9.         Range("k1").Resize(res.length,res[0].length).Value2=res;
   
10. }

复制代码

LIUZHU

WPS软件打开测试即可