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

sunjing-zxl

【字典2班.012】sunjing-zxl  交作业

1. Sub sunjing_zxl()
   
2. Dim arr1, arr2(), arr3(), arr4()
   
3. Dim n As Long, k As Long, L_1 As Long, L_2 As Long, L_3 As Long
   
4. Range("D2:I65536").ClearContents
   
5. arr1 = Range("A2:B" & [A65536].End(xlUp).Row)
   
6. k = UBound(arr1, 1)
   
7. L_1 = -1
   
8. L_2 = -1
   
9. L_3 = -1
   
10. For n = 1 To k
    
11. If arr1(n, 2) < 2000 Then
    
12. L_1 = L_1 + 1
    
13. ReDim Preserve arr2(1, L_1)
    
14. arr2(0, L_1) = arr1(n, 1)
    
15. arr2(1, L_1) = arr1(n, 2)
    
16. ElseIf arr1(n, 2) < 3000 Then
    
17. L_2 = L_2 + 1
    
18. ReDim Preserve arr3(1, L_2)
    
19. arr3(0, L_2) = arr1(n, 1)
    
20. arr3(1, L_2) = arr1(n, 2)
    
21. Else
    
22. L_3 = L_3 + 1
    
23. ReDim Preserve arr4(1, L_3)
    
24. arr4(0, L_3) = arr1(n, 1)
    
25. arr4(1, L_3) = arr1(n, 2)
    
26. End If
    
27. Next n
    
28. Range("D2").Resize(UBound(arr2, 2), 2) = Application.WorksheetFunction.Transpose(arr2)
    
29. Range("F2").Resize(UBound(arr3, 2), 2) = Application.WorksheetFunction.Transpose(arr3)
    
30. Range("H2").Resize(UBound(arr4, 2), 2) = Application.WorksheetFunction.Transpose(arr4)
    
31. End Sub

复制代码

开心妙妙

1. Sub 开心妙妙()
   
2.     Dim i As Integer
   
3.     Dim n As Integer
   
4.     Dim n1 As Integer
   
5.     Dim n2 As Integer
   
6.     Dim Arr
   
7.     Dim Arr2()
   
8.     Dim Arr3()
   
9.     Dim Arr4()
   
10.     Range("d3:I" & Range("i65536").End(xlUp).Row) = ""
    
11.     Arr = Range("A1:B" & Range("b65536").End(xlUp).Row)
    
12.     For i = 2 To UBound(Arr, 1)
    
13.         If Arr(i, 2) <= 2000 Then
    
14.             n = n + 1
    
15.             ReDim Preserve Arr2(1 To 2, 1 To n)
    
16.             Arr2(1, n) = Arr(i, 1)
    
17.             Arr2(2, n) = Arr(i, 2)
    
18.         ElseIf Arr(i, 2) <= 3000 Then
    
19.             n1 = n1 + 1
    
20.             ReDim Preserve Arr3(1 To 2, 1 To n1)
    
21.             Arr3(1, n1) = Arr(i, 1)
    
22.             Arr3(2, n1) = Arr(i, 2)
    
23.         Else
    
24.             n2 = n2 + 1
    
25.             ReDim Preserve Arr4(1 To 2, 1 To n2)
    
26.             Arr4(1, n2) = Arr(i, 1)
    
27.             Arr4(2, n2) = Arr(i, 2)
    
28.         End If
    
29.     Next
    
30.     Range("d3").Resize(n, 2) = Application.Transpose(Arr2)
    
31.     Range("F3").Resize(n1, 2) = Application.Transpose(Arr3)
    
32.     Range("H3").Resize(n2, 2) = Application.Transpose(Arr4)
    
33. End Sub

复制代码

乐满地

1. Sub 乐满地()
   
2.     Dim arr, brr1(), brr2(), brr3()
   
3.     Dim x As Long
   
4.     Dim k1 As Long
   
5.     Dim k2 As Long
   
6.     Dim k3 As Long
   
7.     Dim t
   
8.     t = Timer
   
9.     arr = Range("a2:b" & Range("a65536").End(xlUp).Row)
   
10. 
    
11.     For x = 1 To Range("a65536").End(xlUp).Row - 1
    
12.         If arr(x, 2) < 2000 Then
    
13.             k1 = k1 + 1
    
14.             ReDim Preserve brr1(1 To 2, 1 To k1)
    
15.             brr1(1, k1) = arr(x, 1)
    
16.             brr1(2, k1) = arr(x, 2)
    
17.         ElseIf arr(x, 2) < 3000 Then
    
18.             k2 = k2 + 1
    
19.             ReDim Preserve brr2(1 To 2, 1 To k2)
    
20.             brr2(1, k2) = arr(x, 1)
    
21.             brr2(2, k2) = arr(x, 2)
    
22.         Else
    
23.             k3 = k3 + 1
    
24.             ReDim Preserve brr3(1 To 2, 1 To k3)
    
25.             brr3(1, k3) = arr(x, 1)
    
26.             brr3(2, k3) = arr(x, 2)
    
27.         End If
    
28.     Next
    
29.     Range("d3").Resize(k1, 2) = Application.Transpose(brr1)
    
30.     Range("f3").Resize(k2, 2) = Application.Transpose(brr2)
    
31.     Range("h3").Resize(k3, 2) = Application.Transpose(brr3)
    
32.     MsgBox Timer - t
    
33. End Sub
    
34. 
    

复制代码

徐淑颖

终于可以交作业了
Sub 徐淑颖()
Dim I  As Integer
Dim J As Integer
J = Range("B65536").End(xlUp).Row

Dim ARR(), ARR1(), ARR2(), ARR3()
ARR() = Range("A2:B" & J)

For I = 1 To J - 1
    Select Case ARR(I, 2)
        Case Is >= 3000
          K = K + 1
           ReDim Preserve ARR3(1 To 2, 1 To K)
           ARR3(1, K) = ARR(I, 1)
           ARR3(2, K) = ARR(I, 2)
           
        Case Is >= 2000
          N = N + 1
           ReDim Preserve ARR2(1 To 2, 1 To N)
           ARR2(1, N) = ARR(I, 1)
           ARR2(2, N) = ARR(I, 2)
           
           Case Else
          M = M + 1
           ReDim Preserve ARR1(1 To 2, 1 To M)
           ARR1(1, M) = ARR(I, 1)
           ARR1(2, M) = ARR(I, 2)
        
     End Select
     
     Next
     
    Range("D3").Resize(M, 2) = Application.Transpose(ARR1)
   
    Range("F3").Resize(N, 2) = Application.Transpose(ARR2)
   
    Range("H3").Resize(K, 2) = Application.Transpose(ARR3)
   

End Sub

我不知道呀

字典2班 038号 我不知道呀 上交作业!

1. Sub 我不知道呀()
   
2. On Error Resume Next
   
3. t = Timer
   
4.     Dim Arr, Arr1(), Arr2(), Arr3(), i As Long, k As Long, l As Long, h As Long
   
5.     Dim arr11(), arr22(), arr33()
   
6.     Arr = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row).Value
   
7.         For i = 1 To UBound(Arr)
   
8.             Select Case Arr(i, 2)
   
9.             Case Is < 2000
   
10.                 k = k + 1
    
11.                 ReDim Preserve Arr1(1 To k)
    
12.                 ReDim Preserve arr11(1 To k)
    
13.                 Arr1(k) = Arr(i, 1)
    
14.                 arr11(k) = Arr(i, 2)
    
15.             Case Is < 3000
    
16.                 l = l + 1
    
17.                 ReDim Preserve Arr2(1 To l)
    
18.                 ReDim Preserve arr22(1 To l)
    
19.                 Arr2(l) = Arr(i, 1)
    
20.                 arr22(l) = Arr(i, 2)
    
21.             Case Else
    
22.                 h = h + 1
    
23.                 ReDim Preserve Arr3(1 To h)
    
24.                 ReDim Preserve arr33(1 To h)
    
25.                 Arr3(h) = Arr(i, 1)
    
26.                 arr33(h) = Arr(i, 2)
    
27.             End Select
    
28.         Next
    
29.     Range("d3").Resize(k, 1) = Application.Transpose(Arr1)
    
30.     Range("e3").Resize(k, 1) = Application.Transpose(arr11)
    
31.    
    
32.      Range("f3").Resize(l, 1) = Application.Transpose(Arr2)
    
33.     Range("g3").Resize(l, 1) = Application.Transpose(arr22)
    
34.    
    
35.      Range("h3").Resize(h, 1) = Application.Transpose(Arr3)
    
36.     Range("i3").Resize(h, 1) = Application.Transpose(arr33)
    
37.     MsgBox Timer - t
    
38. End Sub

复制代码

兰江自由鱼

1. Option Base 1
   
2. Sub 兰江自由鱼()
   
3. Dim Arr, Arr_T1(), Arr_T2(), Arr_S1(), Arr_S2(), Arr_R1(), Arr_R2()
   
4. Dim i As Long, x As Long, y As Long, Z As Long
   
5. Arr = Range("A2:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value
   
6. x = 0
   
7. y = 0
   
8. Z = 0
   
9. For i = 1 To UBound(Arr)
   
10.    If Arr(i, 2) < 2000 Then
    
11.        x = x + 1
    
12.       ReDim Preserve Arr_R1(1 To x)
    
13.      ReDim Preserve Arr_R2(1 To x)
    
14.       Arr_R1(x) = Arr(i, 1)
    
15.       Arr_R2(x) = Arr(i, 2)
    
16.       
    
17.     ElseIf Arr(i, 2) < 3000 Then
    
18.       y = y + 1
    
19.       ReDim Preserve Arr_S1(1 To y)
    
20.        ReDim Preserve Arr_S2(1 To y)
    
21.           Arr_S1(y) = Arr(i, 1)
    
22.           Arr_S2(y) = Arr(i, 2)
    
23.        Else
    
24.        Z = Z + 1
    
25.       ReDim Preserve Arr_T1(1 To Z)
    
26.       ReDim Preserve Arr_T2(1 To Z)
    
27.            Arr_T1(Z) = Arr(i, 1)
    
28.            Arr_T2(Z) = Arr(i, 2)
    
29.      End If
    
30.          
    
31. Next i
    
32. Range("D3").Resize(UBound(Arr_R1), 1).Value = Application.Transpose(Arr_R1)
    
33. Range("e3").Resize(UBound(Arr_R2), 1).Value = Application.Transpose(Arr_R2)
    
34. Range("F3").Resize(UBound(Arr_S1), 1).Value = Application.Transpose(Arr_S1)
    
35. Range("G3").Resize(UBound(Arr_S2), 1).Value = Application.Transpose(Arr_S2)
    
36. Range("h3").Resize(UBound(Arr_T1), 1).Value = Application.Transpose(Arr_T1)
    
37. Range("i3").Resize(UBound(Arr_T2), 1).Value = Application.Transpose(Arr_T2)
    
38. 
    
39. End Sub

复制代码

不知道能不能通过？

jy854509

1. Sub 工资分类()
   
2. Dim arr(), arr1(), top_1, i, top_2, top_3
   
3. On Error Resume Next
   
4. Dim t
   
5. t = Timer
   
6. top_1 = 1
   
7. top_2 = 1
   
8. top_3 = 1
   
9.   arr() = Range("a2", Cells(Rows.Count, "b").End(xlUp))
   
10.      For i = 1 To UBound(arr())
    
11.         If arr(i, 2) < 2000 Then
    
12.            If top_1 >= top_2 And top_1 >= top_3 Then
    
13.              ReDim Preserve arr1(1 To 6, 1 To top_1)
    
14.            End If
    
15.              arr1(1, top_1) = arr(i, 1)
    
16.              arr1(2, top_1) = arr(i, 2)
    
17.              top_1 = top_1 + 1
    
18.            ElseIf arr(i, 2) < 3000 Then
    
19.            If top_2 >= top_1 And top_2 >= top_3 Then
    
20.              ReDim Preserve arr1(1 To 6, 1 To top_2)
    
21.            End If
    
22.              arr1(3, top_2) = arr(i, 1)
    
23.              arr1(4, top_2) = arr(i, 2)
    
24.              top_2 = top_2 + 1
    
25.         Else
    
26.            If top_3 >= top_1 And top_3 >= top_2 Then
    
27.               ReDim Preserve arr1(1 To 6, 1 To top_3)
    
28.            End If
    
29.              arr1(5, top_3) = arr(i, 1)
    
30.              arr1(6, top_3) = arr(i, 2)
    
31.              top_3 = top_3 + 1
    
32.         End If
    
33.      Next i
    
34. Range("o3").Resize(UBound(arr1, 2), UBound(arr1, 1)) = WorksheetFunction.Transpose(arr1)
    
35. MsgBox Timer - t
    
36. End Sub

复制代码

判断稍多呀，其实可以直接把变量与数组的最大下标进行比较呀。   ------wcymiss

liuts

1. Sub liuts()
   
2.     Dim arr, a%, b%, c%, x%, brr(), t As Double, m As Double
   
3.     t = Timer
   
4.     With Sheet1
   
5.         .Range("d3:i65536").ClearContents
   
6.         arr = .Range("a1").CurrentRegion
   
7.         ReDim brr(1 To 6, 1 To 1)
   
8.         For x = 2 To UBound(arr)
   
9.             m = UBound(brr, 2)
   
10.             If arr(x, 2) >= 1000 And arr(x, 2) < 2000 Then
    
11.                 a = a + 1
    
12.                 If a > m Then m = m + 1
    
13.                 ReDim Preserve brr(1 To 6, 1 To m)
    
14.                 brr(1, a) = arr(x, 1): brr(2, a) = arr(x, 2)
    
15.             ElseIf arr(x, 2) >= 2000 And arr(x, 2) < 3000 Then
    
16.                 b = b + 1
    
17.                 If b > m Then m = m + 1
    
18.                 ReDim Preserve brr(1 To 6, 1 To m)
    
19.                 brr(3, b) = arr(x, 1): brr(4, b) = arr(x, 2)
    
20.             ElseIf arr(x, 2) >= 3000 Then
    
21.                 c = c + 1
    
22.                 If c > m Then m = m + 1
    
23.                 ReDim Preserve brr(1 To 6, 1 To m)
    
24.                 brr(5, c) = arr(x, 1): brr(6, c) = arr(x, 2)
    
25.             End If
    
26.         Next
    
27.         .Range("d3").Resize(m, 6) = Application.Transpose(brr)
    
28.     End With
    
29.     MsgBox Timer - t
    
30. End Sub

复制代码

思路正确，判断稍多。               -------wcymiss

jiangslly

jiangslly
Sub huizong9()
Dim a, b, r, d, l, m, n, c
Dim arr, arr1, arr2, arr3
r = Sheet1.[a65536].End(xlUp).Row
   'arr = Sheet1.Range("a2:b" & r)
   With Sheet1
b = Application.WorksheetFunction.CountIf(Range("b2:b" & r), "<2000") - _
Application.WorksheetFunction.CountIf(Range("b2:b" & r), "<1000")
c = Application.WorksheetFunction.CountIf(Sheet1.Range("b2:b" & r), "<3000") - _
Application.WorksheetFunction.CountIf(Sheet1.Range("b2:b" & r), "<2000")
d = Application.WorksheetFunction.CountIf(Sheet1.Range("b2:b" & r), ">3000")
ReDim arr1(1 To b, 1 To 2)
ReDim arr2(1 To c, 1 To 2)
ReDim arr3(1 To d, 1 To 2)
For a = 2 To r
If Cells(a, 2).Value >= 1000 And Cells(a, 2).Value < 2000 Then
m = m + 1
arr1(m, 2) = Cells(a, 2).Value
arr1(m, 1) = Cells(a, 1).Value
End If
If Cells(a, 2).Value >= 2000 And Cells(a, 2).Value < 3000 Then
n = n + 1
arr2(n, 2) = Cells(a, 2).Value
arr2(n, 1) = Cells(a, 1).Value
End If
If Cells(a, 2).Value > 3000 Then
l = l + 1
arr3(l, 2) = Cells(a, 2).Value
arr3(l, 1) = Cells(a, 1).Value
End If
Next
   Range("D3").Resize(UBound(arr1), 2) = arr1
   Range("F3").Resize(UBound(arr2), 2) = arr2
   Range("H3").Resize(UBound(arr3), 2) = arr3
End With
End Sub

笑姻缘

1. Sub sort()
   
2. Dim Rng() As Variant, arr1() As Variant, arr2() As Variant, arr3() As Variant
   
3. Dim FinalCell As Long, i As Long, j As Long, num1() As Long
   
4. ReDim num1(1 To 3)
   
5. ReDim arr1(1 To 2, 1 To 1)
   
6. ReDim arr2(1 To 2, 1 To 1)
   
7. ReDim arr3(1 To 2, 1 To 1)
   
8. '****************************读入数据****************************
   
9. FinalCell = Cells(Rows.Count, 1).End(xlUp).Row
   
10. Rng() = Range("A2:B" & FinalCell)
    
11. '****************************分类********************************
    
12. num1(1) = num1(2) = num1(3) = 0
    
13. For i = 2 To FinalCell
    
14. Select Case (Rng(i - 1, 2))
    
15. Case Is < 2000
    
16.     num1(1) = num1(1) + 1
    
17.     If num1(1) > UBound(arr1, 2) Then ReDim Preserve arr1(1 To 2, 1 To num1(1))
    
18.     arr1(1, num1(1)) = Rng(i - 1, 1)
    
19.     arr1(2, num1(1)) = Rng(i - 1, 2)
    
20. Case Is < 3000
    
21.     num1(2) = num1(2) + 1
    
22.    If num1(2) > UBound(arr2, 2) Then ReDim Preserve arr2(1 To 2, 1 To num1(2))
    
23.     arr2(1, num1(2)) = Rng(i - 1, 1)
    
24.     arr2(2, num1(2)) = Rng(i - 1, 2)
    
25. Case Is >= 3000
    
26.     num1(3) = num1(3) + 1
    
27.    If num1(3) > UBound(arr3, 2) Then ReDim Preserve arr3(1 To 2, 1 To num1(3))
    
28.     arr3(1, num1(3)) = Rng(i - 1, 1)
    
29.     arr3(2, num1(3)) = Rng(i - 1, 2)
    
30. End Select
    
31. Next i
    
32. '******************************读出数据*****************************
    
33. Range("D3:E" & num1(1)) = Application.Transpose(arr1())
    
34. Range("F3:G" & num1(2)) = Application.Transpose(arr2())
    
35. Range("H3:I" & num1(3)) = Application.Transpose(arr3())
    
36. End Sub
    

复制代码

    num1(1) = num1(2) = num1(3) = 0  个人认为这个用法不妥。由于事先定义了num1为long型数据，所以这句不会造成影响。如果没有定义为long，num1(1)将会=flase，而另两个元素仍未被赋值。
     其实定义了long然后又声明了数组的大小后，数组里的元素会默认为0的。                                  ----------wcymiss