VBA统计

mrb178

你好，
表1中“厂商名称”有多个且都有重复，要求在表2中记录所有的厂商（不能重复），并统计相应厂商的“验货总数”（求和）、A和B的个数（计数）。
请用VBA编写，多谢！

小花鹿

用一个4列的数组存放结果，用一个字典记录行号，然后，循环原始数据......................................

mrb178

本人新手，请大神编写以便学习，谢谢。

lydiacl

用什么代码拉，透视表搞定不就可以拉

粤北一蚯

1. Option Explicit
   
2. 
   
3. Sub aa()
   
4.     Dim xrow%,  i%, k%, m%
   
5.     Dim dic As Object, x$
   
6.     Dim arr, brr
   
7.     arr = Sheet1.Range("a1").CurrentRegion.Value
   
8.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
   
9.     Set dic = CreateObject("Scripting.dictionary")
   
10.     For i = 3 To UBound(arr)
    
11.         x = arr(i, 1) & arr(i, 4)
    
12.         If dic.Exists(x) Then
    
13.             m = dic(x)
    
14.             If arr(i, 4) = "A" Then
    
15.                 brr(m, 3) = brr(m, 3) + 1
    
16.             ElseIf arr(i, 4) = "B" Then
    
17.                 brr(m, 4) = brr(m, 4) + 1
    
18.             End If
    
19.         Else
    
20.             k = k + 1
    
21.             dic(x) = k
    
22.             brr(k, 1) = arr(i, 1)
    
23.             brr(k, 2) = brr(k, 2) + arr(i, 3)
    
24.             If arr(i, 4) = "A" Then
    
25.                 brr(k, 3) = brr(k, 3) + 1
    
26.             ElseIf arr(i, 4) = "B" Then
    
27.                 brr(k, 4) = brr(k, 4) + 1
    
28.             End If
    
29.         End If
    
30.     Next
    
31.     With Sheet2
    
32.         xrow = .Range("a1").CurrentRegion.Rows.Count
    
33.         If xrow > 2 Then
    
34.             .Range([a3], Cells(xrow, 4)).Clear
    
35.         End If
    
36.         .[a3].Resize(UBound(brr), UBound(brr, 2)) = brr
    
37.         With Range("a3", Cells(2 + dic.Count, 4))
    
38.             .Borders(xlEdgeLeft).LineStyle = xlContinuous
    
39.             .Borders(xlEdgeTop).LineStyle = xlContinuous
    
40.             .Borders(xlEdgeBottom).LineStyle = xlContinuous
    
41.             .Borders(xlEdgeRight).LineStyle = xlContinuous
    
42.             .Borders(xlInsideVertical).LineStyle = xlContinuous
    
43.             .Borders(xlInsideHorizontal).LineStyle = xlContinuous
    
44.             .HorizontalAlignment = xlCenter
    
45.             .VerticalAlignment = xlCenter
    
46.         End With
    
47.     End With
    
48.     Set dic = Nothing
    
49.     Erase arr
    
50.     Erase brr
    
51.     x = ""
    
52. End Sub
    

复制代码

zax010

Sub zz()
    Dim d, ar
    Set d = CreateObject("Scripting.Dictionary")
    ar = Sheet1.Range("A1").CurrentRegion
    For i = 3 To UBound(ar)
        If Not d.exists(ar(i, 1)) Then
            s = Array(ar(i, 3), 0, 0)
            If ar(i, 4) = "A" Then s(1) = 1
            If ar(i, 4) = "B" Then s(2) = 1
            d(ar(i, 1)) = s
        Else
            a = d(ar(i, 1)): a(0) = a(0) + ar(i, 3)
            If ar(i, 4) = "A" Then a(1) = a(1) + 1
            If ar(i, 4) = "B" Then a(2) = a(2) + 1
            d(ar(i, 1)) = a
        End If
    Next
    With Sheet2
        .[a3].Resize(d.Count) = Application.Transpose(d.keys)
        .[b3].Resize(d.Count, 3) = Application.Rept(d.items, 1)
    End With
End Sub

zax010

>>>>>>>>>>>>>>>>>>>>>>>>>



统计.rar (20.22 KB, 下载次数: 44)

2017-4-21 15:15 上传

点击文件名下载附件

魂断蓝桥

Sub 查询()
Dim cnn As Object
Dim Sql As String
Set cnn = CreateObject("ADODB.CONNECTION")
Application.ScreenUpdating = False
Sheet1.Columns("A:A").TextToColumns DataType:=xlDelimited, FieldInfo:=Array(1, 2)
cnn.Open "Provider=Microsoft.Jet.OleDb.4.0;Extended Properties='Excel 8.0;HDR=YES'; Data Source=" & ThisWorkbook.FullName
Sql = "select 厂商名称,验货数量 AS T1,0 AS T2 from [sheet1$A2:D] WHERE 类型='A' UNION ALL " _
        & "select 厂商名称,0,验货数量  from [sheet1$A2:D] WHERE 类型='B' "
Sql = "SELECT 厂商名称,SUM(T1)+SUM(T2),SUM(T1),SUM(T2) FROM (" & Sql & ") GROUP BY 厂商名称"
Sheet2.Activate
Range("a3:d999").ClearContents
[a3].CopyFromRecordset cnn.Execute(Sql)
cnn.Close: Set cnn = Nothing
Application.ScreenUpdating = True
End Sub

mrb178

zax010 发表于 2017-4-21 15:14
Sub zz()
    Dim d, ar
    Set d = CreateObject("Scripting.Dictionary")

不愧是大神，代码也精炼。收藏学习了...也谢谢各位！

AOZHIJUN1

直接用透视最快了