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

Sellby

刚才发错了，重发：

1. Sub sellby()
   
2. 
   
3.     Dim arr, brr, crr(1 To 6000, 1 To 7)
   
4. 
   
5.     Dim i%, j%, x%, y%, t
   
6. 
   
7.     Dim sh As Worksheet
   
8. 
   
9. t = Timer
   
10. 
    
11.     Set sh = ThisWorkbook.Sheets("数据源")
    
12. 
    
13.     arr = sh.Range("g1").CurrentRegion
    
14. 
    
15.     x = 0: y = 0
    
16. 
    
17.     For i = 7 To UBound(arr, 2)
    
18. 
    
19.         x = x + 1
    
20. 
    
21.         crr(x, 1) = arr(3, i)
    
22. 
    
23.         crr(x, 2) = arr(4, i)
    
24. 
    
25.         crr(x, 3) = arr(5, i)
    
26. 
    
27.         crr(x, 4) = arr(6, i)
    
28. 
    
29.         For j = x + 9 To UBound(arr)
    
30. 
    
31.             If arr(j, i) > 0 Then
    
32. 
    
33.                 crr(x + y, 5) = arr(j, 2)
    
34. 
    
35.                 crr(x + y, 6) = arr(j, 5)
    
36. 
    
37.                 crr(x + y, 7) = arr(j, i)
    
38. 
    
39.                  y = y + 1
    
40. 
    
41.             ElseIf arr(j, i) = 0 And j > x Then
    
42. 
    
43.                 Exit For
    
44. 
    
45.            End If
    
46. 
    
47.        Next j
    
48. 
    
49.        x = x + y - 1: y = 0
    
50. 
    
51.     Next i
    
52. 
    
53.    
    
54. 
    
55.     With Sheets("练习结果")
    
56. 
    
57.         .Cells.ClearContents
    
58. 
    
59.         .Range("a2").Resize(x, 7) = crr
    
60. 
    
61.     End With
    
62. 
    
63. MsgBox Timer - t
    
64. 
    
65. End Sub
    

复制代码

缔造者

1. Sub 格式转换()
   
2. Dim arr, arr1, arr2
   
3. Dim i&, j&, t
   
4. t = Timer
   
5. Application.ScreenUpdating = False
   
6. arr = Range("a9:jd3978")
   
7. arr1 = Range("g3:jd6")
   
8. j = 7
   
9. ReDim arr2(1 To UBound(arr), 1 To 7)
   
10. For i = 2 To UBound(arr) - 1
    
11. If arr(i - 1, j) = "" Then
    
12. arr2(i - 1, 1) = arr1(1, j - 6)
    
13. arr2(i - 1, 2) = arr1(2, j - 6)
    
14. arr2(i - 1, 3) = arr1(3, j - 6)
    
15. arr2(i - 1, 4) = arr1(4, j - 6)
    
16. End If
    
17. arr2(i - 1, 5) = arr(i, 2)
    
18. arr2(i - 1, 6) = arr(i, 5)
    
19. arr2(i - 1, 7) = arr(i, j)
    
20. If arr(i + 1, j) = "" Then
    
21. j = j + 1
    
22. End If
    
23. Next i
    
24. With Sheets("结果")
    
25. .Range("h2").Resize(UBound(arr2), 7).ClearContents
    
26. .Range("h2").Resize(UBound(arr2), 7) = arr2
    
27. End With
    
28. Application.ScreenUpdating = True
    
29. MsgBox Timer - t
    
30. End Sub
    

复制代码

哈哈，看到群里的讨论，抄袭的。
热身题之格式转换.rar (539.88 KB, 下载次数: 6)

2013-10-16 21:08 上传

点击文件名下载附件

xdragon

1. Sub bomtranspose()
   
2. Dim pm(), gg(), zhq(), arr(), r As Integer, i As Integer, j As Integer, jg(), m As Long, t As Single, k As Byte
   
3. t = Timer
   
4. With Sheet1
   
5. r = .Cells(Rows.Count, 2).End(3).Row
   
6. pm = .Range("B10:B" & r)
   
7. gg = .Range("E10:E" & r)
   
8. arr = .Range("G10:JD" & r)
   
9. zhq = .Range("G3:JD6")
   
10. ReDim jg(1 To Application.WorksheetFunction.CountA(.Range("G10:JD" & r)), 1 To 7)
    
11. End With
    
12. For j = 1 To 258
    
13.   For k = 1 To 4
    
14.      jg(m + 1, k) = zhq(k, j)
    
15.   Next
    
16.   For i = 1 To UBound(arr)
    
17.      If arr(i, j) <> "" Then
    
18.          m = m + 1
    
19.          jg(m, 5) = pm(i, 1)
    
20.          jg(m, 6) = gg(i, 1)
    
21.          jg(m, 7) = arr(i, j)
    
22.      End If
    
23.   Next
    
24. Next
    
25. Sheet2.Range("A2:G" & UBound(jg)) = jg
    
26. MsgBox "共使用:" & Format(Round(Timer - t, 3), "0.000") & "秒"
    
27. End Sub

复制代码

估计很慢不过总算达到效果了。。。

123小木头人

呵呵

w2001pf

Sub 格式转换()
    Dim arr, arrj, brr, i As Integer, j As Integer, x As Integer, n As Integer
    t = Timer
    arr = Sheets("数据源").Range("A10:JD3977")
    brr = Sheets("数据源").Range("G3:JD6")
    ReDim arrj(1 To UBound(arr), 1 To 7) As String
    j = 7
    For i = 1 To UBound(arr)
        If arr(i, j) = 1 Then
            n = n + 1
            If n = 1 Then
                For x = 1 To 4
                    arrj(i, x) = brr(x, j - 6)
                Next x
                arrj(i, 5) = arr(i, 2): arrj(i, 6) = arr(i, 5): arrj(i, 7) = arr(i, j)
            Else
                arrj(i, 5) = arr(i, 2): arrj(i, 6) = arr(i, 5): arrj(i, 7) = arr(i, j)
            End If
        End If
        If arr(i, j) = "" Then j = j + 1: i = i - 1: n = 0
    Next i

    With Sheets("结果")
        .Range("A1:G3977").ClearContents
        .Range("A2").Resize(i - 1, 7) = arrj
    End With
    MsgBox Timer - t
End Sub

ly258

怎么都开贴了，我刚做完，给看看吧！

Sub zh()
Dim i, j, m, n, a, b, r, l
Dim arr, arrjg
r = 2
n = 10
arr = Worksheets("数据源").Range("a1:jd4000")
a = UBound(arr, 2)
b = UBound(arr, 1)
Debug.Print a, b
For i = 7 To UBound(arr, 2)
    l = 9
    For j = 3 To 6
    Worksheets("结果").Cells(r, l) = Worksheets("数据源").Cells(j, i)
        l = l + 1
    Next j
   
    For m = n To UBound(arr, 1)
        If Worksheets("数据源").Cells(m, i) = "" Then
            n = m
            Exit For
        Else
            Worksheets("结果").Cells(r, 13) = Worksheets("数据源").Cells(m, 2)
            Worksheets("结果").Cells(r, 14) = Worksheets("数据源").Cells(m, 5)
            Worksheets("结果").Cells(r, 15) = Worksheets("数据源").Cells(m, i)
            r = r + 1
        End If
    Next m
Next i
End Sub