【VBA字典数组201301班】课前热身习题四

wp8680

原跟贴有错误

1. Sub test()
   
2.     Dim d1, d2, d3, x As Double
   
3.     Dim arr, brr, crr, k As Long
   
4.     Set d1 = CreateObject("scripting.dictionary")
   
5.     Set d2 = CreateObject("scripting.dictionary")
   
6.     Set d3 = CreateObject("scripting.dictionary")
   
7.     arr = Range("a3:c" & Range("a" & Cells.Rows.Count).End(xlUp).Row)
   
8.     For k = 1 To UBound(arr)
   
9.         If d1.Exists(arr(k, 1)) Then
   
10.             If arr(k, 2) > d1(arr(k, 1)) Then d1(arr(k, 1)) = arr(k, 2)
    
11.         Else
    
12.             d1(arr(k, 1)) = arr(k, 2)
    
13.         End If
    
14.         If d3.Exists(arr(k, 1)) Then d3(arr(k, 1)) = d3(arr(k, 1)) + 1 Else d3(arr(k, 1)) = 1
    
15.     Next k
    
16.     For k = 1 To UBound(arr)
    
17.         If d2.Exists(arr(k, 1)) Then
    
18.             x = d1(arr(k, 1)) - arr(k, 2)
    
19.             If x <> 0 And x < d2(arr(k, 1)) Then d2(arr(k, 1)) = x
    
20.         Else
    
21.             d2(arr(k, 1)) = 0
    
22.         End If
    
23.     Next k
    
24.     Range("m3").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d1.keys)
    
25.     brr = d1.items
    
26.     crr = d2.items
    
27.     For k = 1 To d1.Count
    
28.         Range("n2").Offset(k, 0) = brr(k - 1) - crr(k - 1)
    
29.     Next k
    
30.     Range("o3").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d3.items)
    
31. End Sub

复制代码

monicaj

请审阅。。。新代码如下：
Sub exe4()
    t = Timer
    Dim arr
    Dim brr(1 To 2000, 1 To 4)
    Dim i As Long, k As Integer, row1 As Integer

    Dim d As New Dictionary
    arr = Range("a2:c" & Range("c1048576").End(xlUp).Row)

    For i = 1 To UBound(arr, 1)
        If d.Exists(arr(i, 1)) = False Then
            k = k + 1
            d(arr(i, 1)) = k
            brr(k, 1) = arr(i, 1)
           brr(k, 2) = arr(i, 2)
            brr(k, 3) = arr(i, 3)
   
        Else
            row1 = d(arr(i, 1))
            brr(row1, 3) = brr(row1, 3) + arr(i, 3)

            If brr(row1, 4) = "" Then
                If arr(i, 2) < brr(row1, 2) Then
                    brr(row1, 4) = brr(row1, 2)
                    brr(row1, 2) = arr(i, 2)
                    
                Else
               
                    brr(row1, 4) = arr(i, 2)
                End If
            Else
                If arr(i, 2) > brr(row1, 4) Then
                    brr(row1, 2) = brr(row1, 4)
                    brr(row1, 4) = arr(i, 2)
                ElseIf arr(i, 2) > brr(row1, 2) Then
                    brr(row1, 2) = arr(i, 2)
                End If
            End If

        End If
    Next
    Range("j2").Resize(UBound(brr), 3) = brr
    MsgBox Timer - t

End Sub

ldxhzy

前几个习题因不会，没做。要开课了，勉强做了习题四。

w2001pf

这是修改后的。Sub 汇总()    t = Timer
    Application.ScreenUpdating = False
    Dim d As New Dictionary
    Dim d1 As New Dictionary
    Dim d2 As New Dictionary
    Dim d3 As New Dictionary
    Dim d4 As New Dictionary
    With Sheets("Sheet1")
        rowend = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A3:C" & rowend)
    End With
    For i = 1 To UBound(arr)
        d(arr(i, 1)) = d(arr(i, 1)) + 1
        If Not d1.Exists(arr(i, 1)) Then
            d1(arr(i, 1)) = arr(i, 2)
        Else
            If d1(arr(i, 1)) < arr(i, 2) Then d1(arr(i, 1)) = arr(i, 2)
        End If
    Next i
    For i = 1 To UBound(arr)
        If arr(i, 2) <> d1(arr(i, 1)) Then d2(arr(i, 1)) = d2(arr(i, 1)) + 1
    Next i
    For i = 1 To UBound(arr)
        If d2(arr(i, 1)) = 0 Then
            arr(i, 2) = arr(i, 2)
        ElseIf d2(arr(i, 1)) > 0 Then
            If arr(i, 2) = d1(arr(i, 1)) Then
                If Not d4.Exists(arr(i, 1)) Then d4(arr(i, 1)) = "": arr(i, 2) = 0
            End If
        End If
    Next i
    For i = 1 To UBound(arr)
        If d3(arr(i, 1)) < arr(i, 2) Then d3(arr(i, 1)) = arr(i, 2)
    Next i
    ReDim arr1(1 To d.Count, 1 To 3)
    With Sheets("Sheet1")
        .Range("J3").Resize(d.Count, 3) = ""
        .Range("J3").Resize(d.Count) = Application.Transpose(d.Keys)
        .Range("K3").Resize(d.Count) = Application.Transpose(d3.Items)
        .Range("L3").Resize(d.Count) = Application.Transpose(d.Items)
    End With

    MsgBox Timer - t
    Application.ScreenUpdating = True
End Sub

w2001pf

修改后的答案在14楼，请老师指导。