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

缔造者

整了个半成品，只提取了3列数据，框线里面的数据绕不过来啦，太笨了。

1. Sub 格式转换升级()
   
2. Dim arr, arr1$(1 To 5000, 1 To 20)
   
3. Dim i&, j&, m&, m1&, t
   
4. t = Timer
   
5. Application.ScreenUpdating = False
   
6. arr = Sheets("数据源").Range("a1").CurrentRegion
   
7. m = 1
   
8. For i = 2 To UBound(arr)
   
9. If arr(i, 1) <> arr(i - 1, 1) Then
   
10. arr1(m, 1) = arr(i, 1)
    
11. arr1(m, 2) = arr(i, 2)
    
12. arr1(m, 3) = arr(1, 5)
    
13. arr1(m + 1, 3) = arr(1, 6)
    
14. arr1(m + 2, 3) = arr(1, 7)
    
15. m = m + 3
    
16. End If
    
17. Next i
    
18. With Sheets("结果").Range("l2")
    
19. .CurrentRegion.Clear
    
20. .Resize(UBound(arr1), UBound(arr1, 2)) = arr1
    
21. End With
    
22. Application.ScreenUpdating = True
    
23. MsgBox Timer - t
    
24. End Sub

复制代码

liuguansky

1. Sub ResultTest()
   
2.     Dim t
   
3.     t = Timer
   
4.     Dim ArrTemp, ArrResult$(1 To 1000, 1 To 20)
   
5.     Dim LngK&, LngI&, LngArr&(2), Str$, LngJ&
   
6.     ArrTemp = Worksheets("数据源").Range("A1").CurrentRegion.Value
   
7.     For LngI = 2 To UBound(ArrTemp)
   
8.         If ArrTemp(LngI, 1) <> ArrTemp(LngI - 1, 1) _
   
9.             Or ArrTemp(LngI, 2) <> ArrTemp(LngI - 1, 2) Then
   
10.             Erase LngArr
    
11.             LngK = LngK + 1
    
12.             ArrResult(LngK, 1) = ArrTemp(LngI, 1)
    
13.             ArrResult(LngK, 2) = ArrTemp(LngI, 2)
    
14.             ArrResult(LngK, 3) = ArrTemp(1, 5)
    
15.             LngK = LngK + 1
    
16.             ArrResult(LngK, 3) = ArrTemp(1, 6)
    
17.             LngK = LngK + 1
    
18.             ArrResult(LngK, 3) = ArrTemp(1, 7)
    
19.         End If
    
20.         For LngJ = 5 To 7
    
21.             If Not IsEmpty(ArrTemp(LngI, LngJ)) Then
    
22.                 LngArr(LngJ - 5) = LngArr(LngJ - 5) + 1
    
23.                 ArrResult(LngK + LngJ - 7, 3 + LngArr(LngJ - 5)) = ArrTemp(LngI, 3)
    
24.             End If
    
25.         Next LngJ
    
26.     Next LngI
    
27.     With Worksheets("结果")
    
28.         .Cells.ClearContents
    
29.         .[a2].Resize(LngK, 20) = ArrResult
    
30.     End With
    
31.     Debug.Print Timer - t
    
32. End Sub

复制代码

这题好,对数组应用有帮助.

w2001pf

尽管开贴了，还是改进一下，我的电脑上运行只比0.008左右。
Sub 格式转换()
    Dim arr, arrj, i As Integer, l1 As Integer, l2 As Integer, l3 As Integer, n As Integer, m As Integer
    Dim d As New Dictionary
    Dim d1 As New Dictionary
    t = Timer
    arr = Sheets("数据源").Range("A2:G449")
    For i = 1 To UBound(arr)
        If d.Exists(arr(i, 1)) = False Then
            d(arr(i, 1)) = arr(i, 2)
        End If
    Next i
    ReDim arrj(1 To 3 * d.Count, 1 To 10) As String
    For i = 1 To UBound(arr)
        If d1.Exists(arr(i, 1)) = False Then
            n = n + 1
            d1(arr(i, 1)) = ""
            l1 = 3: l2 = 3: l3 = 3
            arrj(3 * (n - 1) + 1, 1) = arr(i, 1): arrj(3 * (n - 1) + 1, 2) = arr(i, 2)
            arrj(3 * (n - 1) + 1, 3) = "CAP前": arrj(3 * (n - 1) + 2, 3) = "CAP后": arrj(3 * (n - 1) + 3, 3) = "完成品"
            If arr(i, 5) <> "" Then l1 = l1 + 1: arrj(3 * (n - 1) + 1, l1) = arr(i, 3)
            If arr(i, 6) <> "" Then l2 = l2 + 1: arrj(3 * (n - 1) + 2, l2) = arr(i, 3)
            If arr(i, 7) <> "" Then l3 = l3 + 1: arrj(3 * (n - 1) + 3, l3) = arr(i, 3)
        Else
            If arr(i, 5) <> "" Then l1 = l1 + 1: arrj(3 * (n - 1) + 1, l1) = arr(i, 3)
            If arr(i, 6) <> "" Then l2 = l2 + 1: arrj(3 * (n - 1) + 2, l2) = arr(i, 3)
            If arr(i, 7) <> "" Then l3 = l3 + 1: arrj(3 * (n - 1) + 3, l3) = arr(i, 3)
        End If
    Next i
    With Sheets("结果")
        .Range("A1:J194") = ""
        .Range("A2").Resize(UBound(arrj), 10) = arrj
    End With
    MsgBox Timer - t
End Sub