统计和求和

墨子wx

要求:按A2至A5客户名称，应收金额求和，统计已结清个数（结算方式，"微信"）和统计未结清个数

求助统计和求和.zip (12.3 KB, 下载次数: 13)

2024-6-19 10:11 上传

点击文件名下载附件
求助

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.6.19
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("数据表")
   
6.         r = .Cells(.Rows.Count, "a").End(xlUp).Row
   
7.         arr = .[a1].Resize(r, 8)
   
8.     End With
   
9.     ReDim brr(1 To 1000, 1 To 4)
   
10.     For i = 2 To UBound(arr)
    
11.         s = arr(i, 3)
    
12.         p1 = IIf(arr(i, 6) = "已结清", 1, 0)
    
13.         p2 = IIf(arr(i, 6) = "未结清", 1, 0)
    
14.         If Not d.exists(s) Then
    
15.             m = m + 1
    
16.             d(s) = m
    
17.             brr(m, 1) = s
    
18.             brr(m, 2) = arr(i, 4)
    
19.             brr(m, 3) = p1
    
20.             brr(m, 4) = p2
    
21.         Else
    
22.             r = d(s)
    
23.             brr(r, 2) = brr(r, 2) + arr(i, 4)
    
24.             brr(r, 3) = brr(r, 3) + p1
    
25.             brr(r, 4) = brr(r, 4) + p2
    
26.         End If
    
27.     Next
    
28.     With Sheets("汇总")
    
29.         .UsedRange.Offset(1).ClearContents
    
30.         With .[a2].Resize(m, 4)
    
31.             .Value = brr
    
32.             .Borders.LineStyle = 1
    
33.             .HorizontalAlignment = xlCenter
    
34.             .VerticalAlignment = xlCenter
    
35.         End With
    
36.     End With
    
37.     Set d = Nothing
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    

复制代码

feilanga

1. Sub 统计()
   
2.     arr = Sheet1.Range("A1:H" & Sheet1.Cells(Rows.Count, "C").End(xlUp).Row)
   
3.     Dim dic As Object
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     ReDim brr(1 To UBound(arr), 1 To 4)
   
6.     For i = 2 To UBound(arr)
   
7.         If Len(arr(i, 3)) Then
   
8.             Key = arr(i, 3)
   
9.             If Not dic.Exists(Key) Then
   
10.                 k = k + 1
    
11.                 If arr(i, 6) = "已结清" Then
    
12.                     jq = jq + 1
    
13.                 Else
    
14.                     wjq = wjq + 1
    
15.                 End If
    
16.                 dic(Key) = k
    
17.                 brr(k, 1) = arr(i, 3)
    
18.                 brr(k, 2) = arr(i, 4)
    
19.                 brr(k, 3) = jq
    
20.                 brr(k, 4) = wjq
    
21.                 jq = 0
    
22.                 wjq = 0
    
23.             Else
    
24.                 R = dic(Key)
    
25.                 If arr(i, 6) = "已结清" Then
    
26.                     jq = jq + 1
    
27.                 Else
    
28.                     wjq = wjq + 1
    
29.                 End If
    
30.                 brr(R, 2) = brr(R, 2) + arr(i, 4)
    
31.                 brr(R, 3) = brr(R, 3) + jq
    
32.                 brr(R, 4) = brr(R, 4) + wjq
    
33.                 jq = 0
    
34.                 wjq = 0
    
35.             End If
    
36.         End If
    
37.     Next
    
38.     Sheet2.Range("A2").Resize(10000, 4).ClearContents
    
39.     Sheet2.Range("A2:D10000").Borders.LineStyle = xlNone
    
40.     Sheet2.Range("A2").Resize(k, 4) = brr
    
41.     Sheet2.Range("A2").Resize(k, 4).Borders.LineStyle = 1

复制代码

Qs18

试一下.........

Qs18

试一下..............

tel3033

换一种方法

tel3033

1. Sub Test()
   
2.     Dim Conn As Object, Rst As Object
   
3.     Dim strConn As String, strSQL As String
   
4.     Dim i As Integer, PathStr As String
   
5.     Set Conn = CreateObject("ADODB.Connection")
   
6.     Set Rst = CreateObject("ADODB.Recordset")
   
7.     PathStr = ThisWorkbook.FullName
   
8.     Select Case Application.Version * 1
   
9.     Case Is <= 11
   
10.         strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    
11.     Case Is >= 12
    
12.         strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
13.     End Select
    
14.     strSQL = "select DISTINCT 客户名称,状态,Count(*) as 计数 From [数据表$] Group By 客户名称,状态 Union All " _
    
15.     & "select DISTINCT 客户名称,'应收金额' as 状态,SUM(应收金额) as 计数 from [数据表$] GROUP BY 客户名称"
    
16.     strSQL = "TransForm Sum(计数) Select 客户名称 From (" & strSQL & ") Group By 客户名称 pivot 状态 In('应收金额','已结清','未结清')"
    
17.     Conn.Open strConn
    
18.     Set Rst = Conn.Execute(strSQL)
    
19.     With Sheets("汇总")
    
20.         .Cells.Clear
    
21.         For i = 0 To Rst.Fields.Count - 1
    
22.             .Cells(1, i + 1) = Rst.Fields(i).Name
    
23.         Next i
    
24.         .Range("A2").CopyFromRecordset Rst
    
25.         .Cells.EntireColumn.AutoFit
    
26.     End With
    
27.     Rst.Close
    
28.     Conn.Close
    
29.     Set Conn = Nothing
    
30.     Set Rst = Nothing
    
31. End Sub

复制代码

sdytsxd991122

墨子wx

多谢以上各位大佬，估计要慢慢消化。