【字典与数组二期1班】第一讲作业工资分类（必做）【已开贴】

wcymiss

【课时一作业】工资分类.rar (63.79 KB, 下载次数: 238)

2011-12-17 15:08 上传

点击文件名下载附件
本题是为了考察大家是否掌握数组的定位知识以及动态数组的运用。所以，请使用数组方式答题。谢谢。

代码直接在回帖时贴出，不需再上传附件。
过程名请使用id名。（数字开头的id请前面加字母a）
非上交作业请勿回帖，谢谢。

更新说明：表头可利用现有结果，不需用数组生成。

那么的帅

1. 
   
2. Sub 那么的帅()
   
3.     Dim Arr1, Arr11()
   
4.     Dim Row1 As Long, I As Long, A1 As Long, A2 As Long, A3 As Long, M As Long
   
5.     With Sheets("Sheet1")
   
6.         Row1 = .Range("A" & .Rows.Count).End(xlUp).Row
   
7.         Arr1 = .Range("A2:B" & Row1)
   
8.         M = M + 1
   
9.         ReDim Arr11(1 To 6, 1 To M)
   
10.         For I = 1 To UBound(Arr1)
    
11.             Select Case Arr1(I, 2)
    
12.             Case Is < 2000
    
13.                 A1 = A1 + 1
    
14.                 If A1 > UBound(Arr11, 2) Then
    
15.                     M = M + 1
    
16.                     ReDim Preserve Arr11(1 To 6, 1 To M)
    
17.                 End If
    
18.                 Arr11(1, A1) = Arr1(I, 1)
    
19.                 Arr11(2, A1) = Arr1(I, 2)
    
20.             Case Is < 4000
    
21.                 A2 = A2 + 1
    
22.                 If A2 > UBound(Arr11, 2) Then
    
23.                     M = M + 1
    
24.                     ReDim Preserve Arr11(1 To 6, 1 To M)
    
25.                 End If
    
26.                 Arr11(3, A2) = Arr1(I, 1)
    
27.                 Arr11(4, A2) = Arr1(I, 2)
    
28.             Case Else
    
29.                 A3 = A3 + 1
    
30.                 If A3 > UBound(Arr11, 2) Then
    
31.                     M = M + 1
    
32.                     ReDim Preserve Arr11(1 To 6, 1 To M)
    
33.                 End If
    
34.                 Arr11(5, A3) = Arr1(I, 1)
    
35.                 Arr11(6, A3) = Arr1(I, 2)
    
36.             End Select
    
37.         Next I
    
38.         .Range("D3:I" & .Rows.Count).ClearContents
    
39.         .Range("D3").Resize(M, 6) = Application.Transpose(Arr11)
    
40.     End With
    
41. End Sub

复制代码

吹毛求疵一下：既然用了变量M，那判断里面的UBound就可以用M来代替了。             --------wcymiss

Benol

1. Sub Benol()
   
2. Dim src
   
3. Dim d As New Dictionary
   
4. Set d(0) = New Dictionary
   
5. Set d(-1) = New Dictionary
   
6. Set d(-2) = New Dictionary
   
7. 
   
8. src = Range(Cells(2, 1), Cells([A65536].End(3).Row, 2))
   
9. 
   
10. For i = 1 To UBound(src)
    
11. d((src(i, 2) >= 2000) + (src(i, 2) >= 3000))(src(i, 1)) = src(i, 2)
    
12. Next
    
13. 
    
14. Range("d3:i65536").ClearContents
    
15. 
    
16. For i = 0 To 2
    
17. If d(-i).Count > 0 Then
    
18.   Range("D3").Offset(0, i * 2).Resize(d(-i).Count) = Application.Transpose(d(-i).Keys)
    
19.   Range("D3").Offset(0, 1 + 2 * i).Resize(d(-i).Count) = Application.Transpose(d(-i).Items)
    
20. End If
    
21. Next
    
22. End Sub

复制代码

Benol

趁着尚未开帖，优化下代码结构

1. 
   
2. Option Base 1
   
3. Sub Benol()
   
4. Dim src, dest()
   
5. Dim cnt(1 To 3) As Long, bound_dest As Long, k As Integer
   
6. src = Range([A2], Cells([A65536].End(3).Row, 2))
   
7. For i = 1 To UBound(src)
   
8.    k = 1 - (src(i, 2) >= 3000) - (src(i, 2) >= 2000)
   
9.    cnt(k) = cnt(k) + 1
   
10.     If cnt(k) > bound_dest Then
    
11.      ReDim Preserve dest(6, cnt(k))
    
12.      bound_dest = cnt(k)
    
13.     End If
    
14.   dest(k * 2 - 1, cnt(k)) = src(i, 1)
    
15.   dest(k * 2, cnt(k)) = src(i, 2)
    
16. Next
    
17. Range("D3:I65536").ClearContents
    
18. Range("d3:i3").Resize(bound_dest) = Application.Transpose(dest)
    
19. End Sub

复制代码

windimi007

吴姐辛苦了~~~~~~~{:1612:}
本以为方法1会快点，结果还是方法2快点。{:4712:}
方法1：

1. Sub windimi007_1()
   
2.     Dim arr, arr1() As String
   
3.     Dim i&, r1&, r2&, r3&
   
4.     arr = Range("A1").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         Select Case arr(i, 2)
   
7.         Case Is < 2000
   
8.             r1 = r1 + 1
   
9.             If r1 > r2 And r1 > r3 Then ReDim Preserve arr1(1 To 6, 1 To r1)
   
10.             arr1(1, r1) = arr(i, 1)
    
11.             arr1(2, r1) = arr(i, 2)
    
12.         Case Is < 3000
    
13.             r2 = r2 + 1
    
14.             If r2 > r1 And r2 > r3 Then ReDim Preserve arr1(1 To 6, 1 To r2)
    
15.             arr1(3, r2) = arr(i, 1)
    
16.             arr1(4, r2) = arr(i, 2)
    
17.         Case Else
    
18.             r3 = r3 + 1
    
19.             If r3 > r1 And r3 > r2 Then ReDim Preserve arr1(1 To 6, 1 To r3)
    
20.             arr1(5, r3) = arr(i, 1)
    
21.             arr1(6, r3) = arr(i, 2)
    
22.         End Select
    
23.     Next i
    
24.     Erase arr
    
25.     Range("D3").Resize(UBound(arr1, 2), 6) = WorksheetFunction.Transpose(arr1)
    
26.     Erase arr1
    
27. End Sub

复制代码

方法2：

1. Sub windimi007_2()
   
2.     Dim arr, arr1() As String, arr2() As String, arr3() As String
   
3.     Dim i&, r1&, r2&, r3&
   
4.     arr = Range("A1").CurrentRegion
   
5.     For i = 2 To UBound(arr)
   
6.         Select Case arr(i, 2)
   
7.         Case Is < 2000
   
8.             r1 = r1 + 1
   
9.             ReDim Preserve arr1(1 To 2, 1 To r1)
   
10.             arr1(1, r1) = arr(i, 1)
    
11.             arr1(2, r1) = arr(i, 2)
    
12.         Case Is < 3000
    
13.             r2 = r2 + 1
    
14.             ReDim Preserve arr2(1 To 2, 1 To r2)
    
15.             arr2(1, r2) = arr(i, 1)
    
16.             arr2(2, r2) = arr(i, 2)
    
17.         Case Else
    
18.             r3 = r3 + 1
    
19.             ReDim Preserve arr3(1 To 2, 1 To r3)
    
20.             arr3(1, r3) = arr(i, 1)
    
21.             arr3(2, r3) = arr(i, 2)
    
22.         End Select
    
23.     Next i
    
24.     Erase arr
    
25.     Range("D3").Resize(UBound(arr1, 2), 2) = WorksheetFunction.Transpose(arr1)
    
26.     Range("F3").Resize(UBound(arr2, 2), 2) = WorksheetFunction.Transpose(arr2)
    
27.     Range("H3").Resize(UBound(arr3, 2), 2) = WorksheetFunction.Transpose(arr3)
    
28.     Erase arr1
    
29.     Erase arr2
    
30.     Erase arr3
    
31. End Sub

复制代码

代码一的判断稍多，只要直接对比r1、r2、r3与ubound(arr,2)就可以了。--------wcymiss

jsgslgd

回帖试试看

1. Sub jsgslgd()
   
2.     Dim arr, arr1(), arr2(), arr3()
   
3.     Dim i1, i2, i3, i
   
4.     Range("d3:i65536").ClearContents
   
5.     arr = Range("a2:b" & Range("a65536").End(3).Row).Value
   
6.     For i = 1 To UBound(arr)
   
7.     Select Case arr(i, 2)
   
8.            Case Is >= 3000
   
9.                 i1 = i1 + 1
   
10.                 ReDim Preserve arr1(1 To 2, 1 To i1)
    
11.                 arr1(1, i1) = arr(i, 1)
    
12.                 arr1(2, i1) = arr(i, 2)
    
13.            Case Is >= 2000
    
14.                 i2 = i2 + 1
    
15.                 ReDim Preserve arr2(1 To 2, 1 To i2)
    
16.                 arr2(1, i2) = arr(i, 1)
    
17.                 arr2(2, i2) = arr(i, 2)
    
18.            Case Is >= 1000
    
19.                 i3 = i3 + 1
    
20.                 ReDim Preserve arr3(1 To 2, 1 To i3)
    
21.                 arr3(1, i3) = arr(i, 1)
    
22.                 arr3(2, i3) = arr(i, 2)
    
23.     End Select
    
24.     Next
    
25.     Range("d3").Resize(i3, 2) = Application.Transpose(arr3)
    
26.     Range("f3").Resize(i2, 2) = Application.Transpose(arr2)
    
27.     Range("h3").Resize(i1, 2) = Application.Transpose(arr1)
    
28. End Sub

复制代码

ldxhzy

1. 
   

复制代码

1. Private Sub ldxhzy()
   
2.     Dim I As Long, J As Long, T1 As Long, T2 As Long, T3 As Long
   
3.     Dim Sou(), Tag1(), Tag2(), Tag3()
   
4.     I = ActiveSheet.UsedRange.Rows.Count
   
5.     T1 = 0
   
6.     T2 = 0
   
7.     T3 = 0
   
8.     Sou() = ActiveSheet.Range(Cells(2, 1), Cells(I, 2)).Value
   
9.     For J = 1 To I - 1
   
10.         Select Case Sou(J, 2)
    
11.             Case Is < 2000
    
12.                 T1 = T1 + 1
    
13.                 ReDim Preserve Tag1(1 To 2, 1 To T1)
    
14.                 Tag1(1, T1) = Sou(J, 1)
    
15.                 Tag1(2, T1) = Sou(J, 2)
    
16.             Case Is >= 3000
    
17.                 T3 = T3 + 1
    
18.                 ReDim Preserve Tag3(1 To 2, 1 To T3)
    
19.                 Tag3(1, T3) = Sou(J, 1)
    
20.                 Tag3(2, T3) = Sou(J, 2)
    
21.             Case Else
    
22.                 T2 = T2 + 1
    
23.                 ReDim Preserve Tag2(1 To 2, 1 To T2)
    
24.                 Tag2(1, T2) = Sou(J, 1)
    
25.                 Tag2(2, T2) = Sou(J, 2)
    
26.          End Select
    
27.     Next J
    
28. 
    
29.     T1 = UBound(Tag1, 2)
    
30.     T2 = UBound(Tag2, 2)
    
31.     T3 = UBound(Tag3, 2)
    
32.     Range(Cells(3, 4), Cells(T1 + 2, 5)) = Application.Transpose(Tag1())
    
33.     Range(Cells(3, 6), Cells(T2 + 2, 7)) = Application.Transpose(Tag2())
    
34.     Range(Cells(3, 8), Cells(T3 + 2, 9)) = Application.Transpose(Tag3())
    
35. End Sub
    

复制代码

happym8888

Option Base 1
Private Sub Happym8888_Click()
Dim i As Integer, XingMing() As String, GongZi() As String
Dim j As Integer, XingMing12() As String, GongZi12() As String
Dim m As Integer, XingMing23() As String, GongZi23() As String
Dim n As Integer, XingMing3() As String, GongZi3() As String
j = 0
m = 0
n = 0
For i = 1 To 32500
ReDim Preserve XingMing(i)
ReDim Preserve GongZi(i)
If Cells(i, 1) = "" Then Exit For
XingMing(i) = Sheet1.Cells(i + 1, 1)
GongZi(i) = Sheet1.Cells(i + 1, 2)
If Val(GongZi(i)) >= 3000 Then
n = n + 1
ReDim Preserve XingMing3(n)
ReDim Preserve GongZi3(n)
XingMing3(n) = XingMing(i)
GongZi3(n) = GongZi(i)
ElseIf Val(GongZi(i)) < 3000 And Val(GongZi(i)) >= 2000 Then
m = m + 1
ReDim Preserve XingMing23(m)
ReDim Preserve GongZi23(m)
XingMing23(m) = XingMing(i)
GongZi23(m) = GongZi(i)
ElseIf Val(GongZi(i)) < 2000 And Val(GongZi(i)) >= 1000 Then
j = j + 1
ReDim Preserve XingMing12(j)
ReDim Preserve GongZi12(j)
XingMing12(j) = XingMing(i)
GongZi12(j) = GongZi(i)
End If
Next i
For j = 1 To UBound(GongZi12())
Cells(j + 2, "D") = XingMing12(j)
Cells(j + 2, "E") = GongZi12(j)
Next j
For m = 1 To UBound(GongZi23())
Cells(m + 2, "F") = XingMing23(m)
Cells(m + 2, "G") = GongZi23(m)
Next m
For n = 1 To UBound(GongZi3())
Cells(n + 2, "H") = XingMing3(n)
Cells(n + 2, "I") = GongZi3(n)
Next n
End Sub

qushui

1. Option Base 1
   
2. Private Sub qushui()
   
3. Dim r&, k1&, k2&, k3&
   
4. Dim aa, bb(), cc(), dd()
   
5. [d:i].Clear
   
6. r = [a65536].End(3).Row
   
7. aa = Range("a2:b" & r)
   
8. For i = 1 To r - 1
   
9. If aa(i, 2) < 2000 Then
   
10. k1 = k1 + 1
    
11. ReDim Preserve bb(2, k1)
    
12. bb(1, k1) = aa(i, 1)
    
13. bb(2, k1) = aa(i, 2)
    
14. ElseIf aa(i, 2) < 3000 Then
    
15. k2 = k2 + 1
    
16. ReDim Preserve cc(2, k2)
    
17. cc(1, k2) = aa(i, 1)
    
18. cc(2, k2) = aa(i, 2)
    
19. Else
    
20. k3 = k3 + 1
    
21. ReDim Preserve dd(2, k3)
    
22. dd(1, k3) = aa(i, 1)
    
23. dd(2, k3) = aa(i, 2)
    
24. End If
    
25. Next i
    
26. [d3].Resize(k1, 2) = Application.Transpose(bb)
    
27. [f3].Resize(k2, 2) = Application.Transpose(cc)
    
28. [h3].Resize(k3, 2) = Application.Transpose(dd)
    
29. End Sub

复制代码

happym8888

1. Option Base 1
   
2. Private Sub Happym8888_Click()
   
3. Dim i As Integer, j As Integer, m As Integer, n As Integer
   
4. Dim XingMing() As Variant, XingMing12() As Variant, XingMing23() As Variant, XingMing3() As Variant
   
5. j = 0: m = 0: n = 0
   
6. For i = 1 To 32500
   
7. ReDim Preserve XingMing(1 To 2, i)
   
8. XingMing(1, i) = Sheet1.Cells(i + 1, 1)
   
9. XingMing(2, i) = Sheet1.Cells(i + 1, 2)
   
10. If XingMing(1, i) = "" Then Exit For
    
11. If Val(XingMing(2, i)) >= 3000 Then
    
12. n = n + 1
    
13. ReDim Preserve XingMing3(1 To 2, n)
    
14. XingMing3(1, n) = XingMing(1, i)
    
15. XingMing3(2, n) = XingMing(2, i)
    
16. ElseIf Val(XingMing(2, i)) < 3000 And Val(XingMing(2, i)) >= 2000 Then
    
17. m = m + 1
    
18. ReDim Preserve XingMing23(1 To 2, m)
    
19. XingMing23(1, m) = XingMing(1, i)
    
20. XingMing23(2, m) = XingMing(2, i)
    
21. Else
    
22. j = j + 1
    
23. ReDim Preserve XingMing12(1 To 2, j)
    
24. XingMing12(1, j) = XingMing(1, i)
    
25. XingMing12(2, j) = XingMing(2, i)
    
26. End If
    
27. Next i
    
28. Range("D3:E" & j) = Application.Transpose(XingMing12())
    
29. Range("f3:G" & m) = Application.Transpose(XingMing23())
    
30. Range("H3:i" & n) = Application.Transpose(XingMing3())
    
31. End Sub

复制代码

原9楼作业重做

主体思路正确，range(rows.count,1).end(3)的方法似乎不会用。另外，="'的判断，在练习（一）内已有更好的代替方法了。
                                                                                                                                               ------------wcymiss