Excel VBA 根据筛选条件自动汇总统计（for 铁虎）

Sub st1()

    Dim r&, i&
    Dim arr, brr
    Dim x, y, z, t, k
    Set d = CreateObject("scripting.dictionary")
    Set d2 = CreateObject("scripting.dictionary")
    Set s = CreateObject("scripting.dictionary")
    Set s2 = CreateObject("scripting.dictionary")
    Set p = CreateObject("scripting.dictionary")
    Set p2 = CreateObject("scripting.dictionary")
    Set q = CreateObject("scripting.dictionary")
    Set q2 = CreateObject("scripting.dictionary")
 
    r = Sheet1.[a65536].End(xlUp).Row
    arr = Range("a2:h" & r)
   
      For i = 1 To UBound(arr)
     
'''''''''''''''''''''''''''''''''''''''''''''筛选条件1

        If Left(arr(i, 7), 6) = "mobile" And (arr(i, 8) = "A" Or arr(i, 8) = "B" Or arr(i, 8) = "C" Or arr(i, 8) = "D") Then
               
             z = arr(i, 2)
            
               x = arr(i, 2): y = arr(i, 6)

                If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
           
                  d(x)(y) = d(x)(y) + 1
                
                    d2(z) = d2(z) + 1
        End If
       
  ''''''''''''''''''''''''''''''''''''''''''''筛选条件2
 
        If Left(arr(i, 7), 6) = "mobile" And Right(arr(i, 7), 5) = "index" And (arr(i, 8) = "E" Or arr(i, 8) = "F" Or arr(i, 8) = "G") Then
               
             z1 = arr(i, 2)
            
               x1 = arr(i, 2): y1 = arr(i, 6)

                If s.exists(x1) = False Then Set s(x1) = CreateObject("Scripting.Dictionary")
           
                  s(x1)(y1) = s(x1)(y1) + 1
                
                    s2(z1) = s2(z1) + 1
         End If
       
 '''''''''''''''''''''''''''''''''''''''''''''筛选条件3
 
          If Left(arr(i, 7), 5) = "index" And Right(arr(i, 7), 5) = "index" And (arr(i, 8) = "X") Then
               
             z2 = arr(i, 2)
            
               x2 = arr(i, 2): y2 = arr(i, 6)

                If p.exists(x2) = False Then Set p(x2) = CreateObject("Scripting.Dictionary")
           
                  p(x2)(y2) = p(x2)(y2) + 1
                
                    p2(z2) = p2(z2) + 1
          End If
       
 '''''''''''''''''''''''''''''''''''''''''''''筛选条件4
 
          If Left(arr(i, 7), 5) = "index" And Right(arr(i, 7), 5) = "index" And (arr(i, 8) = "Y") Then
               
             z3 = arr(i, 2)
            
               x3 = arr(i, 2): y3 = arr(i, 6)

                If q.exists(x3) = False Then Set q(x3) = CreateObject("Scripting.Dictionary")
           
                  q(x3)(y3) = q(x3)(y3) + 1
                
                    q2(z3) = q2(z3) + 1
          End If
       
      Next
   
'''''''''''''''''''''''''''''''''''''''''''''Date & value1 & value2

    k = d.keys: t = d.items
       
    brr = Array("Date", "Value1", "Value2", "Value3", "Value4", "Value5", "Value6", "Value7", "Value8")
    Sheet2.Range("a1:i1") = brr
   
    Sheet2.[a2].Resize(d.Count) = Application.Transpose(k)
    Sheet2.[b2].Resize(d.Count) = Application.Transpose(d2.items)

    For i = 0 To UBound(k)
      Sheet2.Cells(i + 2, 3) = t(i).Count
   
    Next
   
'''''''''''''''''''''''''''''''''''''''''''''value3 & value4
   
     k1 = s.keys: t1 = s.items
       
    'brr = Array("Date", "Value1", "Value2", "Value3", "Value4", "Value5", "Value6", "Value7", "Value8")
    'Sheet2.Range("a1:i1") = brr
   
    'Sheet2.[a2].Resize(d.Count) = Application.Transpose(k)
    Sheet2.[d2].Resize(d.Count) = Application.Transpose(s2.items)

    For i = 0 To UBound(k1)
      Sheet2.Cells(i + 2, 5) = t1(i).Count
   
    Next
   
 '''''''''''''''''''''''''''''''''''''''''''''value5 & value6
   
     k2 = p.keys: t2 = p.items
       
    Sheet2.[f2].Resize(d.Count) = Application.Transpose(p2.items)

    For i = 0 To UBound(k2)
      Sheet2.Cells(i + 2, 7) = t2(i).Count
   
    Next
   
  '''''''''''''''''''''''''''''''''''''''''''''value7 & value8
   
     k3 = q.keys: t3 = q.items
       
    Sheet2.[h2].Resize(d.Count) = Application.Transpose(q2.items)

    For i = 0 To UBound(k3)
      Sheet2.Cells(i + 2, 9) = t3(i).Count
   
    Next
   
   
End Sub