[讨论]有点难度的汇总

泓()

彭兄,检查一下,morganwong兄的是否合你的题意,

如果是,给我们一个警钟,不要什么都一定要VBA解决.

sgrshh29

这个是纯粹用ado打开纪录集来做的，代码不多，但不知道速度如何。其中左边的计数是按机型和故障类型来汇总的。右边的三个计数是按机型、故障类型和地区故障数前三名来汇总的。那个占比是什么不清楚，所以没有做。 7thDZdKK.rar (24.68 KB, 下载次数: 11)

2007-11-29 20:24 上传

点击文件名下载附件
[讨论]有点难度的汇总

彭希仁

Sub xi()
    Dim h As Long
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim y As Long
    Dim z As Long
  Application.ScreenUpdating = False
    t = Timer
Sheet2.Select
    r = Sheet2.[A65536].End(xlUp).Row - 1
    Sheet2.Range("a2").Resize(r, 3).sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
                                       , Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending

    arr = Sheet2.Cells(1, 1).Resize(r + 2, 5)
    For i = 2 To r                          '为加速做准备
        arr(i, 4) = arr(i, 2) & arr(i, 3)
        arr(i, 5) = arr(i, 1) & arr(i, 2) & arr(i, 3)
    Next i
    ReDim arr1(1 To r, 1 To 11)
    ReDim arr2(1 To r, 1 To 2)
    For i = 2 To r + 1
        If arr(i, 5) = arr(i - 1, 5) Then                '地区计数
            arr2(x, 2) = arr2(x, 2) + 1
        Else
            x = x + 1
            arr2(x, 1) = i
            arr2(x, 2) = 1
        End If
        jh = jh + 1
        If arr(i, 4) = arr(i - 1, 4) Then               '故障计数
            arr1(y, 4) = arr1(y, 4) + 1
        Else
            y = y + 1
            arr1(y, 2) = arr(i, 2)
            arr1(y, 3) = arr(i, 3)
            arr1(y, 4) = 1
        End If
        If arr(i, 2) <> arr(i + 1, 2) Then            '生成合计
            y = y + 1
            arr1(y, 2) = arr(i, 2)
            arr1(y, 3) = "合计"
            arr1(y, 4) = jh
            jh = 0
        End If
    Next i
    For h = 7 To 11 Step 2
        j = 1
        For i = 1 To y - 1
            If arr1(i, 3) = "合计" Then i = i + 1
            For j = j To x
                If arr(arr2(j, 1), 4) = arr1(i, 2) & arr1(i, 3) Then
                    If arr2(j, 2) > arr1(i, h) Then            '记录大小和位置
                        arr1(i, h) = arr2(j, 2)
                        arr1(i, h - 1) = j
                    End If
                Else
                    If arr1(i, h) > 0 Then
                        arr2(arr1(i, h - 1), 2) = 0
                        arr1(i, h - 1) = arr(arr2(arr1(i, h - 1), 1), 1)
                    End If
                    Exit For
                End If

            Next j
        Next i
    Next h

    arr1(1, 1) = 1
    For i = 2 To y
        If arr1(i, 2) = arr1(i - 1, 2) Then
            arr1(i, 1) = arr1(i - 1, 1) + 1
        Else
            arr1(i, 1) = 1
        End If
    Next i
    For i = y To 1 Step -1
        If arr1(i, 3) = "合计" Then x = arr1(i, 4)
        arr1(i, 5) = arr1(i, 4) / x
    Next i
    Sheet3.Select
    Cells(3, 1).Resize(y, 11) = arr1
'    Cells(3, 2).Resize(y, 11).Select
 '   Selection.sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range("D3") _
                 , Order2:=xlAscending
   Application.ScreenUpdating = True
    [p2] = Timer - t
End Sub

排序加数组是最快的方法.其实数组部分基本没有花时间,主要排序的时间.

[此贴子已经被作者于2007-11-29 23:39:37编辑过]

彭希仁

QUOTE:

以下是引用morganwong在2007-11-29 19:06:32的发言：

用不着VBA

我还是那句话,要转换思维,此路不通,则彼路通!!

用辅助列的方式!!

我最早也是用if加辅助列实现,速度也不可以

数据量大时countif太多会慢死.

northwolves

QUOTE:

以下是引用彭希仁在2007-11-29 23:00:55的发言：

Sub xi()
    Dim h As Long
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim y As Long
    Dim z As Long
  Application.ScreenUpdating = False
    t = Timer
Sheet2.Select
    r = Sheet2.[A65536].End(xlUp).Row - 1
    Sheet2.Range("a2").Resize(r, 3).sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
                                       , Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending

    arr = Sheet2.Cells(1, 1).Resize(r + 2, 5)
    For i = 2 To r                          '为加速做准备
        arr(i, 4) = arr(i, 2) & arr(i, 3)
        arr(i, 5) = arr(i, 1) & arr(i, 2) & arr(i, 3)
    Next i
    ReDim arr1(1 To r, 1 To 11)
    ReDim arr2(1 To r, 1 To 2)
    For i = 2 To r + 1
        If arr(i, 5) = arr(i - 1, 5) Then                '地区计数
            arr2(x, 2) = arr2(x, 2) + 1
        Else
            x = x + 1
            arr2(x, 1) = i
            arr2(x, 2) = 1
        End If
        jh = jh + 1
        If arr(i, 4) = arr(i - 1, 4) Then               '故障计数
            arr1(y, 4) = arr1(y, 4) + 1
        Else
            y = y + 1
            arr1(y, 2) = arr(i, 2)
            arr1(y, 3) = arr(i, 3)
            arr1(y, 4) = 1
        End If
        If arr(i, 2) <> arr(i + 1, 2) Then            '生成合计
            y = y + 1
            arr1(y, 2) = arr(i, 2)
            arr1(y, 3) = "合计"
            arr1(y, 4) = jh
            jh = 0
        End If
    Next i
    For h = 7 To 11 Step 2
        j = 1
        For i = 1 To y - 1
            If arr1(i, 3) = "合计" Then i = i + 1
            For j = j To x
                If arr(arr2(j, 1), 4) = arr1(i, 2) & arr1(i, 3) Then
                    If arr2(j, 2) > arr1(i, h) Then            '记录大小和位置
                        arr1(i, h) = arr2(j, 2)
                        arr1(i, h - 1) = j
                    End If
                Else
                    If arr1(i, h) > 0 Then
                        arr2(arr1(i, h - 1), 2) = 0
                        arr1(i, h - 1) = arr(arr2(arr1(i, h - 1), 1), 1)
                    End If
                    Exit For
                End If

            Next j
        Next i
    Next h

    arr1(1, 1) = 1
    For i = 2 To y
        If arr1(i, 2) = arr1(i - 1, 2) Then
            arr1(i, 1) = arr1(i - 1, 1) + 1
        Else
            arr1(i, 1) = 1
        End If
    Next i
    For i = y To 1 Step -1
        If arr1(i, 3) = "合计" Then x = arr1(i, 4)
        arr1(i, 5) = arr1(i, 4) / x
    Next i
    Sheet3.Select
    Cells(3, 1).Resize(y, 11) = arr1
'    Cells(3, 2).Resize(y, 11).Select
 '   Selection.sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range("D3") _
                 , Order2:=xlAscending
   Application.ScreenUpdating = True
    [p2] = Timer - t
End Sub

排序加数组是最快的方法.其实数组部分基本没有花时间,主要排序的时间.

好贴！！！

难得彭兄思路如此清楚，佩服之至。

对ADO+SQL有点失望了，呵呵

northwolves

我的代码算法有问题，太慢，不献丑了。

彭希仁

QUOTE:

以下是引用northwolves在2007-11-30 0:01:29的发言：

好贴！！！

难得彭兄思路如此清楚，佩服之至。

对ADO+SQL有点失望了，呵呵

昨天我用ADO+SQL测试，第一次花了15秒，第二次花了53秒，第三次死机了。

看来要用ADO+SQL也可以但要尽量少用（但只能用一句），后面的运算都交给数组来完成。这样就可以省去排序。

SQL = "SELECT 省份,机型,故障,Count(*) as 故障数量 FROM[数据$A1:C65536] GROUP BY 机型,故障,省份"

另外ldy888兄的字典套的方法也很好，效率也很高，应该还有提速的空间。

tycp

QUOTE:

以下是引用彭希仁在2007-11-29 23:00:55的发言：

Sub xi()
    Dim h As Long
    Dim i As Long
    Dim j As Long
    Dim x As Long
    Dim y As Long
    Dim z As Long
  Application.ScreenUpdating = False
    t = Timer
Sheet2.Select
    r = Sheet2.[A65536].End(xlUp).Row - 1
    Sheet2.Range("a2").Resize(r, 3).sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("C2") _
                                       , Order2:=xlAscending, Key3:=Range("A2"), Order3:=xlAscending

    arr = Sheet2.Cells(1, 1).Resize(r + 2, 5)
    For i = 2 To r                          '为加速做准备
        arr(i, 4) = arr(i, 2) & arr(i, 3)
        arr(i, 5) = arr(i, 1) & arr(i, 2) & arr(i, 3)
    Next i
    ReDim arr1(1 To r, 1 To 11)
    ReDim arr2(1 To r, 1 To 2)
    For i = 2 To r + 1
        If arr(i, 5) = arr(i - 1, 5) Then                '地区计数
            arr2(x, 2) = arr2(x, 2) + 1
        Else
            x = x + 1
            arr2(x, 1) = i
            arr2(x, 2) = 1
        End If
        jh = jh + 1
        If arr(i, 4) = arr(i - 1, 4) Then               '故障计数
            arr1(y, 4) = arr1(y, 4) + 1
        Else
            y = y + 1
            arr1(y, 2) = arr(i, 2)
            arr1(y, 3) = arr(i, 3)
            arr1(y, 4) = 1
        End If
        If arr(i, 2) <> arr(i + 1, 2) Then            '生成合计
            y = y + 1
            arr1(y, 2) = arr(i, 2)
            arr1(y, 3) = "合计"
            arr1(y, 4) = jh
            jh = 0
        End If
    Next i
    For h = 7 To 11 Step 2
        j = 1
        For i = 1 To y - 1
            If arr1(i, 3) = "合计" Then i = i + 1
            For j = j To x
                If arr(arr2(j, 1), 4) = arr1(i, 2) & arr1(i, 3) Then
                    If arr2(j, 2) > arr1(i, h) Then            '记录大小和位置
                        arr1(i, h) = arr2(j, 2)
                        arr1(i, h - 1) = j
                    End If
                Else
                    If arr1(i, h) > 0 Then
                        arr2(arr1(i, h - 1), 2) = 0
                        arr1(i, h - 1) = arr(arr2(arr1(i, h - 1), 1), 1)
                    End If
                    Exit For
                End If

            Next j
        Next i
    Next h

    arr1(1, 1) = 1
    For i = 2 To y
        If arr1(i, 2) = arr1(i - 1, 2) Then
            arr1(i, 1) = arr1(i - 1, 1) + 1
        Else
            arr1(i, 1) = 1
        End If
    Next i
    For i = y To 1 Step -1
        If arr1(i, 3) = "合计" Then x = arr1(i, 4)
        arr1(i, 5) = arr1(i, 4) / x
    Next i
    Sheet3.Select
    Cells(3, 1).Resize(y, 11) = arr1
'    Cells(3, 2).Resize(y, 11).Select
 '   Selection.sort Key1:=Range("B3"), Order1:=xlAscending, Key2:=Range("D3") _
                 , Order2:=xlAscending
   Application.ScreenUpdating = True
    [p2] = Timer - t
End Sub

排序加数组是最快的方法.其实数组部分基本没有花时间,主要排序的时间.

要是这样的话,还是快不过字典套字典啊!那个字典套字典没发挥它最高的效率!

没有那个三重排序,后面的数组根本没用!

[此贴子已经被作者于2007-11-30 8:34:12编辑过]

彭希仁

QUOTE:

以下是引用tycp在2007-11-30 8:17:36的发言：

要是这样的话,还是快不过字典套字典啊!那个字典套字典没发挥它最高的效率!

要是这样的话,再加上EXCEL的分类汇总,筛选岂不是更快!

wRP9DIzx.rar (205.55 KB, 下载次数: 27)

2007-11-30 08:34 上传

点击文件名下载附件
[讨论]有点难度的汇总

以上是实际的数据，测试速度对比。

汇总的类别较多时，排序加数组的方法快些。较少时字典好些，字典套字典的方法潜力很大值得深究。

另外EXCEL的分类汇总的前题也是要排序的，而且不能直接出结果，还是得后期处理，所以速度不占有优势。

[此贴子已经被作者于2007-11-30 8:46:34编辑过]

sunahappy

笨办法，Consolidate加数组，速度有些慢，用62楼数据18秒。请高手指正。

Sub 汇总1()
   Application.ScreenUpdating = 0
    Dim arr, arr1, arr2, arr3, arr4
    t = Timer
    sj = "数据"
    bb = "报表"
    ls = "临时"
    Sheets(bb).Select
    Set NewSheet = Worksheets.Add
    NewSheet.Name = ls
    Sheets(sj).Select
    n = [a65536].End(xlUp).Row
    ReDim arr(1 To n, 1 To 5)
    For i = 1 To n
        arr(i, 1) = Trim(Cells(i, 1))
        arr(i, 2) = Trim(Cells(i, 2))
        arr(i, 3) = Trim(Cells(i, 3))
        If i = 1 Then
           arr(i, 4) = "数量"
           arr(i, 5) = arr(i, 2) & arr(i, 3)
        Else: arr(i, 4) = 1
           arr(i, 5) = arr(i, 2) & "-" & arr(i, 3)
        End If
    Next i
   
    Sheets(ls).Select
    Range("a1:a" & n) = Application.Index(arr, , 5)
    Range("b1:b" & n) = Application.Index(arr, , 4)
    s = ls & "!R1C1:R" & n & "C2"
    Sheets(ls).[c1].Consolidate s, xlSum, 1, 1
    x = [c65536].End(xlUp).Row
    arr1 = Range("c2:d" & x)
    Range("a:d").Delete
    ReDim jxgz(1 To UBound(arr1), 1 To 3)
    For i = 1 To UBound(arr1)
        jxgz(i, 1) = Split(arr1(i, 1), "-")(0)
        jxgz(i, 2) = Split(arr1(i, 1), "-")(1)
        jxgz(i, 3) = arr1(i, 2)
    Next i
    Range("a2:a" & UBound(jxgz) + 1) = Application.Index(jxgz, , 1)
    Range("a1") = "机型"
    x = [a1].End(xlDown).Row
    Range("a1:a" & x).AdvancedFilter 2, , [b1], 1
    y = [b1].End(xlDown).Row
    Range("c2:c" & y).FormulaR1C1 = "=COUNTIF(R2C1:R" & x & "C1,RC[-1])"
    arr2 = Range("b2:c" & y)
    gzzl = Application.Sum(Range("c2:c" & y))
    Range("a:d").Delete
    ReDim hz(1 To gzzl + y - 1, 1 To 11)
   
    For i1 = 1 To UBound(arr2)
        x = arr2(i1, 1)
        y = arr2(i1, 2)
        ReDim arr3(1 To y, 1 To 2)
        k = 0
        g = 0
        For i2 = 1 To UBound(jxgz)
            If jxgz(i2, 1) = x Then
               k = k + 1
               arr3(k, 1) = jxgz(i2, 2)
               arr3(k, 2) = jxgz(i2, 3)
               g = g + jxgz(i2, 3)
            End If
        Next i2
        For i3 = 1 To UBound(arr3) + 1
          l = l + 1
          hz(l, 1) = i3
          hz(l, 2) = x
          If i3 <= UBound(arr3) Then
            a = arr3(i3, 1)
            hz(l, 3) = a
            b = arr3(i3, 2)
            hz(l, 4) = b
            hz(l, 5) = Round(b / g, 4)
            ReDim arr4(1 To b, 1 To 2)
            k = 0
            For i4 = 2 To UBound(arr) Step 1
                If arr(i4, 5) = x & "-" & a Then
                   k = k + 1
                   arr4(k, 1) = arr(i4, 1)
                   arr4(k, 2) = arr(i4, 4)
                End If
             Next i4
             Range("a1") = arr(1, 1)
             Range("b1") = arr(1, 4)
             Range("a2:a" & b + 1) = Application.Index(arr4, , 1)
             Range("b2:b" & b + 1) = Application.Index(arr4, , 2)
             s = ls & "!R1C1:R" & b + 1 & "C2"
             Sheets(ls).[c1].Consolidate s, xlSum, 1, 1
             m = [c65536].End(xlUp).Row
             Range("c1:d1").AutoFilter
             Range("c1:d" & m).Sort Key1:=Range("d1"), Order1:=xlDescending, Header:= _
                   xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
                   SortMethod:=xlPinYin, DataOption1:=xlSortNormal
             hz(l, 6) = Range("c2").Value
             hz(l, 7) = Range("d2").Value
             hz(l, 8) = Range("c3").Value
             hz(l, 9) = Range("d3").Value
             hz(l, 10) = Range("c4").Value
             hz(l, 11) = Range("d4").Value
             Range("a:d").Delete
          Else: hz(l, 3) = "合计"
                hz(l, 4) = g
                hz(l, 5) = 1
          End If
        Next i3
    Next i1
    Application.DisplayAlerts = False
    Sheets(ls).Delete
    Application.DisplayAlerts = True
    Sheets(bb).Select
    Range("a3:k" & UBound(hz) + 2) = hz
    For i = 3 To UBound(hz) + 2 Step 1
        If Cells(i, 3) = "合计" Then
        Range("a" & i & ":k" & i).Interior.ColorIndex = 43
        End If
    Next
   Application.ScreenUpdating = 1
   Range("l2") = Timer - t
End Sub