怎么用vba实现根据多个条件进行去重和计数

jeffreykxh

因为数据量特别大，想要用vba实现，根据多个条件进行去重计数。比如：清单是这样的，需要根据房间状态，对房间编号进行去重计数。




并在另一个sheet里面显示出以下结果


求助大神帮忙解决以下。这个数据处理量真的非常大

jeffreykxh

附上附件，求大神解答

zhaojiaoyang200

数据透视不行么？

jeffreykxh

zhaojiaoyang200 发表于 2017-11-7 19:42
数据透视不行么？

还是想尽量能够用VBA解决，这张表经常要更换文件源

chxw68

1. Sub test()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   mybook = ThisWorkbook.FullName
   
7.   With cnn
   
8.     If Application.Version = "11.0" Then
   
9.       .Provider = "microsoft.jet.oledb.4.0"
   
10.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;IMEX=1"";data source=" & mybook
    
11.     Else
    
12.       .Provider = "microsoft.ACE.oledb.12.0"
    
13.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;IMEX=1"";data source=" & mybook
    
14.     End If
    
15.     .Open
    
16.   End With
    
17.   sql = "select 观众编码,观众来源城市,观众来源市区,count(*) as 观看过的场次 from [明细$a1:e] group by 观众编码,观众来源城市,观众来源市区"
    
18.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
19.   With Worksheets("sheet1")
    
20.     .Cells.Delete
    
21.     For j = 0 To rs.Fields.Count - 1
    
22.       .Cells(1, j + 1) = rs.Fields(j).Name
    
23.     Next
    
24.     .Range("a2").CopyFromRecordset rs
    
25.   End With
    
26. End Sub
    

复制代码

chxw68

详见附件。

sdc3211772

Sub ddss()
Dim d As Object, d1 As Object, arr, i, a, n, arr1(), ar, m, j, k
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
arr = Range("a2:e" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To UBound(arr)
    If arr(i, 5) = "开放" Then
        a = arr(i, 1) & arr(i, 2) & arr(i, 3)
        If Not d.exists(a) Then
            n = n + 1
            d(a) = n
            ReDim Preserve arr1(1 To 4, 1 To n)
            arr1(1, n) = arr(i, 1)
            arr1(2, n) = arr(i, 2)
            arr1(3, n) = arr(i, 3)
            arr1(4, n) = arr(i, 4)
        Else
            m = d(a)
            arr1(4, m) = Join(Array(Application.Transpose(arr1(4, m)), arr(i, 4)))
            ar = Application.Transpose(Split(arr1(4, m)))
            For j = 1 To UBound(ar)
                d1(ar(j, 1)) = ""
                arr1(4, m) = Join(d1.keys)
            Next
            d1.RemoveAll
        End If
    End If
    Next
For k = 1 To UBound(Application.Transpose(arr1))
    arr1(4, k) = UBound(Application.Transpose(Split(arr1(4, k))))
Next
Range("i:m").ClearContents
Cells(1, "i").Resize(1, 4) = Array("观众编码", "观众来源城市", "观众来源市区", "观看过的场次")
Cells(2, "i").Resize(n, 4) = Application.Transpose(arr1)
End Sub

jeffreykxh

chxw68 发表于 2017-11-7 20:08
详见附件。

太感谢啦，辛苦啊

LMY123

SQL和字典x统计重复次数

jeffreykxh

sdc3211772 发表于 2017-11-7 22:04
Sub ddss()
Dim d As Object, d1 As Object, arr, i, a, n, arr1(), ar, m, j, k
Set d = CreateObject(" ...

大神能不能抽空帮忙解释一下，谢谢啦