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