分类统计数目

lipeiqiang

Sheet1中A列是不同的Group，B列以后是不同的样品编号。现在想在Sheet2中统计每个group中每个样本的数目，因为有一大批类似的数据，用countif函数太麻烦，想请老师帮助用VBA解决一下。

liulang0808

论坛里有很多类似的例子
查查看吧，字典处理的

liulang0808

Sub 按钮1_Click()
    Application.ScreenUpdating = False
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    arr = Sheets(1).UsedRange
    For j = 1 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then
            For i = 2 To UBound(arr, 2)
                d1(arr(j, 1)) = ""
                If Len(arr(j, i)) > 0 Then
                    d2(arr(j, i)) = ""
                    d(arr(j, 1) & "##" & arr(j, i)) = 1 + d(arr(j, 1) & "##" & arr(j, i))
                End If
            Next i
        End If
    Next j
    ActiveSheet.UsedRange.ClearContents
    [a2].Resize(d1.Count) = WorksheetFunction.Transpose(d1.keys)
    [b1].Resize(1, d2.Count) = d2.keys
    arr = ActiveSheet.UsedRange
    For j = 2 To UBound(arr)
        For i = 2 To UBound(arr, 2)
            arr(j, i) = d(arr(j, 1) & "##" & arr(1, i))
        Next i
    Next j
    ActiveSheet.UsedRange = arr
    Application.ScreenUpdating = True
   
End Sub

liulang0808

看看附件是否能满足需求吧。。。。

lipeiqiang

liulang0808 发表于 2016-9-29 11:51
看看附件是否能满足需求吧。。。。

谢谢，我还是VBA出学者，看到VBA里字典用法很有用，现在还没有完全搞会。

duquancai

1. Sub shishi()
   
2.     Dim brr()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     Sheet1.Activate
   
6.     arr = [a1].CurrentRegion
   
7.     For x = 1 To UBound(arr)
   
8.         For y = 2 To UBound(arr, 2)
   
9.             If d.exists(arr(x, 1)) Then
   
10.                 Set d(arr(x, 1)) = Union(Cells(x, y), d(arr(x, 1)))
    
11.             Else
    
12.                 Set d(arr(x, 1)) = Cells(x, y)
    
13.             End If
    
14.         Next
    
15.     Next
    
16.     For Each Rng In d.items
    
17.         m = m + 1: t = Rng
    
18.         For j = 1 To UBound(t, 2)
    
19.             n = 0
    
20.             For i = 1 To UBound(t)
    
21.                 If t(i, j) <> "" Then
    
22.                     n = n + 1
    
23.                 End If
    
24.             Next
    
25.             ReDim Preserve brr(1 To UBound(t, 2), 1 To m)
    
26.             brr(j, m) = n
    
27.         Next
    
28.     Next
    
29.     Sheet2.Activate
    
30.     Range("a2").Resize(d.Count) = Application.Transpose(d.keys)
    
31.     Range("b2").Resize(d.Count, UBound(t, 2)) = Application.Transpose(brr)
    
32.     Application.ScreenUpdating = True
    
33. End Sub

复制代码

microyip

1. Sub 统计()
   
2.     Dim oRead_Excel_Conn As Object
   
3.     Dim sExcel_Select As String
   
4.     Dim iI As Integer
   
5.    
   
6.     Set oRead_Excel_Conn = CreateObject("Adodb.Connection")
   
7.     oRead_Excel_Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=NO';Data Source=" & ThisWorkbook.FullName
   
8.    
   
9.     For iI = 2 To 4
   
10.         If sExcel_Select <> "" Then sExcel_Select = sExcel_Select & " Union All "
    
11.         sExcel_Select = sExcel_Select & "Select [F1],[F" & iI & "] As F2,1 As F3 From [Sheet1$] Where [F" & iI & "]<>''"
    
12.     Next
    
13.     sExcel_Select = _
    
14.         "TRANSFORM SUM([F3]) SELECT [F1] FROM (" & sExcel_Select & ") GROUP BY [F1] PIVOT [F2] In ('A','B','C')"
    
15.     [G:J].ClearContents
    
16.     [H1:J1] = [{"A","B","C"}]
    
17.     [Sheet2!G2].CopyFromRecordset oRead_Excel_Conn.Execute(sExcel_Select)
    
18.    
    
19.     oRead_Excel_Conn.Close
    
20.     Set oRead_Excel_Conn = Nothing
    
21. End Sub

复制代码

microyip

附上附件以供参考

LMY123

TRANSFORM与字典