设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 培训班 › Excel VBA字典班 › 【字典与数组二期1班】第一讲作业工资分类（必做）【已 ...
12345下一页
返回列表 发新帖
楼主: wcymiss

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

  [复制链接]
liuts
发表于 2011-12-18 12:43 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
本帖最后由 wcymiss 于 2011-12-20 17:40 编辑

  2. Sub liuts()
  3. Dim t
  4. t = Timer
  5. Dim arr, icount%, i%, j%, k%, x%, brr(), crr, m As Integer, k1%
  6. With Sheet1
  7. .Range("d3:i65536").ClearContents
  8. arr = .Range("a1").CurrentRegion
  9. For icount = 1 To 3
  10. m = k: k = 0
  11. For x = 2 To UBound(arr)
  12. Select Case icount
  13. Case 1
  14. If arr(x, 2) >= 1000 And arr(x, 2) < 2000 Then GoSub 100
  15. Case 2
  16. If arr(x, 2) >= 2000 And arr(x, 2) < 3000 Then GoSub 100
  17. Case 3
  18. If arr(x, 2) >= 3000 Then GoSub 100
  19. End Select
  20. Next
  21. Next
  22. brr = Application.Transpose(brr)
  23. .Range("d3").Resize(UBound(brr), 2 * (icount - 1)) = brr
  24. End With
  25. Stop
  26. MsgBox Timer - t
  27. Exit Sub
  28. 100:
  29. k = k + 1
  30. If k <= m Then
  31. brr = Application.Transpose(brr)
  32. ReDim Preserve brr(1 To m, 1 To icount * 2)
  33. brr = Application.Transpose(brr)
  34. brr(icount * 2 - 1, k) = arr(x, 1): brr(icount * 2, k) = arr(x, 2)
  35. Else
  36. ReDim Preserve brr(1 To icount * 2, 1 To k)
  37. brr(icount * 2 - 1, k) = arr(x, 1): brr(icount * 2, k) = arr(x, 2)
  38. End If
  39. Return
  40. End Sub
复制代码

列不需要动态，行动态就行。m = k: k = 0，k、m已经定义为integer了，在未赋值时默认为0。判断稍显复杂。

                                                                                                                         -------wcymiss
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

rxj_0414
发表于 2011-12-18 12:59 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上

  2. Sub rxj_0414()
  3.     Dim N As Long, i As Long, cnt1 As Integer, cnt2 As Integer, cnt3 As Integer
  4.     Dim arr, arr1()
  5.     N = Sheet1.[A65536].End(xlUp).Row
  6.     arr = Sheet1.Range("A2:B" & N)
  7.     ReDim arr1(1 To 6, 1 To 1)
  8.     For i = 1 To UBound(arr, 1)
  9.         If arr(i, 2) < 2000 Then
  10.             cnt1 = cnt1 + 1
  11.             If cnt1 > UBound(arr1, 2) Then ReDim Preserve arr1(1 To 6, 1 To cnt1)
  12.             arr1(1, cnt1) = arr(i, 1)
  13.             arr1(2, cnt1) = arr(i, 2)
  14.         ElseIf arr(i, 2) < 3000 Then
  15.             cnt2 = cnt2 + 1
  16.             If cnt2 >= UBound(arr1, 2) Then ReDim Preserve arr1(1 To 6, 1 To cnt2)
  17.             arr1(3, cnt2) = arr(i, 1)
  18.             arr1(4, cnt2) = arr(i, 2)
  19.         Else
  20.             cnt3 = cnt3 + 1
  21.             If cnt3 >= UBound(arr1, 2) Then ReDim Preserve arr1(1 To 6, 1 To cnt3)
  22.             arr1(5, cnt3) = arr(i, 1)
  23.             arr1(6, cnt3) = arr(i, 2)
  24.         End If
  25.     Next i
  26.     Sheet1.Range("D3:I" & UBound(arr1, 2) + 2) = Application.Transpose(arr1)
  27. End Sub
复制代码

评分

参与人数 1 +10 收起 理由
wcymiss + 10

查看全部评分

回复

使用道具 举报

swabe
发表于 2011-12-18 14:15 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 wcymiss 于 2011-12-19 13:09 编辑


  3. Sub swabe()
  4.     Dim arr, arrtmp()
  5.     Dim i&, j&, k&, L&
  6.     Dim t
  7.     t = Timer
  8.     arr = Range("A2:B" & Range("A65536").End(xlUp).Row)
  9.     j = 1: k = 1: L = 1: x = 1
  10.     For i = 1 To UBound(arr)
  11.         Select Case arr(i, 2) + 0.0000001
  12.         Case 1000 To 2000
  13.             If j = Application.Max(Array(j, k, L)) Then
  14.                 ReDim Preserve arrtmp(1 To 6, 1 To j + 1)
  15.             End If
  16.             arrtmp(1, j) = arr(i, 1)
  17.             arrtmp(2, j) = arr(i, 2)
  18.             j = j + 1
  19.         Case 2000 To 3000
  20.             If k = Application.Max(Array(j, k, L)) Then
  21.                 ReDim Preserve arrtmp(1 To 6, 1 To k + 1)
  22.             End If
  23.             arrtmp(3, k) = arr(i, 1)
  24.             arrtmp(4, k) = arr(i, 2)
  25.             k = k + 1
  26.         Case Is > 3000
  27.             If L = Application.Max(Array(j, k, L)) Then
  28.                 ReDim Preserve arrtmp(1 To 6, 1 To L + 1)
  29.             End If
  30.             arrtmp(5, L) = arr(i, 1)
  31.             arrtmp(6, L) = arr(i, 2)
  32.             L = L + 1
  33.         End Select
  34.     Next
  35.     Range("D3").Resize(UBound(arrtmp, 2), 6) = Application.Transpose(arrtmp)
  36.     MsgBox Timer - t
  37. End Sub
复制代码
请老师指正！谢谢！

稍有取巧，不过对于本例的“工资”能够使用，工资不会超过2位小数。
调用工作表函数max来判断也是一种方法，但不如直接针对数组维数来判断的速度快。
                                                                                    -------wcymiss

评分

参与人数 1 +9 收起 理由
wcymiss + 9

查看全部评分

回复

使用道具 举报

发表于 2011-12-18 14:36 | 显示全部楼层
本帖最后由 wcymiss 于 2011-12-20 09:51 编辑
  1. Sub  JLxiangwei()
  2.     Dim arr, arr1(), arr2(), arr3(), x&, y&, z&, m&
  3.     arr = Range("a2:b" & Range("b65536").End(xlUp).Row)
  4.     For x = 1 To UBound(arr)
  5.         Select Case arr(x, 2)
  6.         Case Is < 2000
  7.             y = y + 1
  8.             ReDim Preserve arr1(1 To 2, 1 To y)
  9.             arr1(1, y) = arr(x, 1)
  10.             arr1(2, y) = arr(x, 2)
  11.         Case Is < 3000
  12.             z = z + 1
  13.             ReDim Preserve arr2(1 To 2, 1 To z)
  14.             arr2(1, z) = arr(x, 1)
  15.             arr2(2, z) = arr(x, 2)
  16.         Case Else
  17.             m = m + 1
  18.             ReDim Preserve arr3(1 To 2, 1 To m)
  19.             arr3(1, m) = arr(x, 1)
  20.             arr3(2, m) = arr(x, 2)
  21.         End Select
  22.     Next x
  23.     Range("d3").Resize(UBound(arr1), 2) = WorksheetFunction.Transpose(arr1)
  24.     Range("f3").Resize(UBound(arr2), 2) = WorksheetFunction.Transpose(arr2)
  25.     Range("h3").Resize(UBound(arr3), 2) = WorksheetFunction.Transpose(arr3)
  26. End Sub
复制代码


最原始的直接的方法。

评分

参与人数 1 +10 收起 理由
wcymiss + 10

查看全部评分

回复

使用道具 举报

发表于 2011-12-18 18:32 | 显示全部楼层
Sub a017()
Dim arr, arr1(), arr2(), arr3()
Dim rowmax, m, n, k, x As Integer
    rowmax = Cells(Rows.Count, "A").End(xlUp).Row
    arr = Range("a2:B" & rowmax)
    For x = 1 To UBound(arr)
        If arr(x, 2) >= 1000 And arr(x, 2) < 2000 Then
            m = m + 1
            ReDim Preserve arr1(1 To 2, 1 To m)
            arr1(1, m) = arr(x, 1)
            arr1(2, m) = arr(x, 2)
            Range("D3").Resize(m, 2) = Application.WorksheetFunction.Transpose(arr1)
        ElseIf arr(x, 2) >= 2000 And arr(x, 2) < 3000 Then
            n = n + 1
            ReDim Preserve arr2(1 To 2, 1 To n)
            arr2(1, n) = arr(x, 1)
            arr2(2, n) = arr(x, 2)
            Range("F3").Resize(n, 2) = Application.WorksheetFunction.Transpose(arr2)
        Else
            k = k + 1
            ReDim Preserve arr3(1 To 2, 1 To k)
            arr3(1, k) = arr(x, 1)
            arr3(2, k) = arr(x, 2)
            Range("h3").Resize(k, 2) = Application.WorksheetFunction.Transpose(arr3)
         End If
     Next
End Sub

点评

wcymiss
在循环内操作单元格了  发表于 2011-12-19 11:04

评分

参与人数 1 +5 收起 理由
wcymiss + 5

查看全部评分

回复

使用道具 举报

csmctjg
发表于 2011-12-18 19:16 | 显示全部楼层

  2. Sub csmctjg()
  3. Dim arr, arr1(), arr2(), arr3(), i&, k1&, k2&, k3&
  4. arr = Range("A2:B" & [A65536].End(xlUp).Row)
  5. For i = 1 To UBound(arr)
  6.     If arr(i, 2) < 2000 Then
  7.         k1 = k1 + 1
  8.         ReDim Preserve arr1(1 To 2, 1 To k1)
  9.         arr1(1, k1) = arr(i, 1)
  10.         arr1(2, k1) = arr(i, 2)
  11.     ElseIf arr(i, 2) < 3000 Then
  12.         k2 = k2 + 1
  13.         ReDim Preserve arr2(1 To 2, 1 To k2)
  14.         arr2(1, k2) = arr(i, 1)
  15.         arr2(2, k2) = arr(i, 2)
  16.     Else
  17.         k3 = k3 + 1
  18.         ReDim Preserve arr3(1 To 2, 1 To k3)
  19.         arr3(1, k3) = arr(i, 1)
  20.         arr3(2, k3) = arr(i, 2)
  21.     End If
  22. Next i
  23. [D3].Resize(k1, 2) = Application.Transpose(arr1)
  24. [F3].Resize(k2, 2) = Application.Transpose(arr2)
  25. [H3].Resize(k3, 2) = Application.Transpose(arr3)
  26. End Sub
复制代码

评分

参与人数 1 +10 收起 理由
wcymiss + 10

查看全部评分

回复

使用道具 举报

发表于 2011-12-18 19:17 | 显示全部楼层
上交作业了，请老师批改！
  1. Sub dtxczjzmp()
  2.     Dim i&, k&, r&, x&, arr, arr1(), arr2(), arr3()

  4.     i = Range("A65536").End(xlUp).Row  ' 最后一行行号
  5.     arr = Range("A2:B" & i)    '把所有人员工资情况装进数组arr

  7.     For i = 1 To UBound(arr)
  8.         If arr(i, 2) < 2000 Then    '把符合条件[1000,2000)人员，从数组arr提取arr1
  9.             k = k + 1
  10.             ReDim Preserve arr1(1 To 2, 1 To i)
  11.             arr1(1, k) = arr(i, 1)
  12.             arr1(2, k) = arr(i, 2)
  13.         ElseIf arr(i, 2) < 3000 Then    '把符合条件[2000,3000)人员，从数组arr提取arr2
  14.             r = r + 1
  15.             ReDim Preserve arr2(1 To 2, 1 To i)
  16.             arr2(1, r) = arr(i, 1)
  17.             arr2(2, r) = arr(i, 2)
  18.         Else                          '把符合条件[3000,∞)人员，从数组arr提取arr3
  19.             x = x + 1
  20.             ReDim Preserve arr3(1 To 2, 1 To i)
  21.             arr3(1, x) = arr(i, 1)
  22.             arr3(2, x) = arr(i, 2)
  23.         End If
  24.     Next i
  25.     'Stop
  26.     With Sheets("sheet1")
  27.         .Range("d2:I65536").Borders.LineStyle = 0
  28.         .Range("d2:I65536").ClearContents
  29.         .Range("d2").Resize(1, 6) = Array("姓名", "工资", "姓名", "工资", "姓名", "工资")
  30.         .Range("d3").Resize(UBound(arr1, 2), 2) = Application.Transpose(arr1)
  31.         .Range("f3").Resize(UBound(arr2, 2), 2) = Application.Transpose(arr2)
  32.         .Range("h3").Resize(UBound(arr3, 2), 2) = Application.Transpose(arr3)
  33.         .Range("d2").Resize(UBound(arr3, 2), 6).Borders.LineStyle = 1
  34.     End With
  35. End Sub
复制代码


评分

参与人数 1 +10 收起 理由
wcymiss + 10

查看全部评分

回复

使用道具 举报

发表于 2011-12-18 19:27 | 显示全部楼层
Sub a017()
Dim arr, arr1(), arr2(), arr3(), arr4(), arr5(), arr6()
Dim rowmax, m, n, k, q, x, y, i, a, b, c As Integer
    rowmax = Cells(Rows.Count, "A").End(xlUp).Row
    arr = Range("a2:B" & rowmax)
    a = Application.WorksheetFunction.CountIf(Range("b2:b" & rowmax), ">=1000") - WorksheetFunction.CountIf(Range("b2:b" & rowmax), ">=2000")
    b = Application.WorksheetFunction.CountIf(Range("b2:b" & rowmax), ">=2000") - WorksheetFunction.CountIf(Range("b2:b" & rowmax), ">=3000")
    c = Application.WorksheetFunction.CountIf(Range("b2:b" & rowmax), ">=3000")
    ReDim arr1(1 To a)
    ReDim arr2(1 To a)
    ReDim arr3(1 To b)
    ReDim arr4(1 To b)
    ReDim arr5(1 To c)
    ReDim arr6(1 To c)
    For x = 1 To UBound(arr)
        If arr(x, 2) >= 1000 And arr(x, 2) < 2000 Then
            m = m + 1
            n = n + 1
            arr1(m) = arr(x, 1)
            arr2(n) = arr(x, 2)
            Range("D3").Resize(a) = WorksheetFunction.Transpose(arr1)
            Range("e3").Resize(a) = WorksheetFunction.Transpose(arr2)
        ElseIf arr(x, 2) >= 2000 And arr(x, 2) < 3000 Then
            k = k + 1
            q = q + 1
            arr3(k) = arr(x, 1)
            arr4(q) = arr(x, 2)
            Range("f3").Resize(b) = WorksheetFunction.Transpose(arr3)
            Range("g3").Resize(b) = WorksheetFunction.Transpose(arr4)
        Else
            y = y + 1
            i = i + 1
            arr5(y) = arr(x, 1)
            arr6(i) = arr(x, 2)
            Range("h3").Resize(c) = WorksheetFunction.Transpose(arr5)
            Range("i3").Resize(c) = WorksheetFunction.Transpose(arr6)
        End If
     Next
End Sub
换一种方法：不知道怎么优化代码啊，速度太慢了

点评

wcymiss
因为你在循环里操作了单元格呀，所以速度很慢。在原贴里修改代码吧。改完了通知我。  发表于 2011-12-19 11:07
回复

使用道具 举报

9lee
发表于 2011-12-19 08:49 | 显示全部楼层
本帖最后由 wcymiss 于 2011-12-20 17:42 编辑

吴姐，我来交作业了：
  1. Sub a9lee()
  2. Dim arr, arr1(), arr2(), arr3()
  3. Dim i As Long, x1 As Long, x2 As Long, x3 As Long
  4. With ThisWorkbook.Sheets("Sheet1")
  5.     arr = Range("a1").CurrentRegion
  6.     For i = 2 To UBound(arr)
  7.         gz = arr(i, 2)
  8.         If gz >= 1000 And gz < 2000 Then
  9.             x1 = x1 + 1
  10.             ReDim Preserve arr1(1 To 2, 1 To x1)
  11.             arr1(1, x1) = arr(i, 1)
  12.             arr1(2, x1) = arr(i, 2)
  13.         ElseIf gz >= 2000 And gz < 3000 Then
  14.             x2 = x2 + 1
  15.             ReDim Preserve arr2(1 To 2, 1 To x2)
  16.             arr2(1, x2) = arr(i, 1)
  17.             arr2(2, x2) = arr(i, 2)
  18.         Else
  19.             x3 = x3 + 1
  20.             ReDim Preserve arr3(1 To 2, 1 To x3)
  21.             arr3(1, x3) = arr(i, 1)
  22.             arr3(2, x3) = arr(i, 2)
  23.         End If
  24.     Next
  25.     .[d3].Resize(x1, 2) = Application.Transpose(arr1)
  26.     .[f3].Resize(x2, 2) = Application.Transpose(arr2)
  27.     .[h3].Resize(x3, 2) = Application.Transpose(arr3)
  28. End With
  29. End Sub
复制代码

if里面的判断还可简化。       -------wcymiss

评分

参与人数 1 +9 收起 理由
wcymiss + 9

查看全部评分

回复

使用道具 举报

pdsxff
发表于 2011-12-19 10:04 | 显示全部楼层

009:pdsxff交作业

本帖最后由 pdsxff 于 2011-12-28 23:04 编辑


交作业，详情见附件！
Sub a009()
Dim xingm, lb1(), lb2(), lb3()
Dim lb1id, lb2id, lb3id, lb1max, lb2max, lb3max, i As Integer
lb1id = 1
lb2id = 1
lb3id = 1
lb1max = Application.CountIf(Range("B2:B6000"), "<2000")
lb2max = Application.CountIf(Range("B2:B6000"), "<3000") - lb1max
lb3max = Application.CountIf(Range("B2:B6000"), ">=3000")
ReDim lb1(1 To lb1max, 1 To 2)
ReDim lb2(1 To lb2max, 1 To 2)
ReDim lb3(1 To lb3max, 1 To 2)
xingm = Range("A2:B" & Cells(65536, 1).End(xlUp).Row).Value

For i = 1 To UBound(xingm)
  Select Case xingm(i, 2)
     Case Is < 2000
       lb1(lb1id, 1) = xingm(i, 1)
       lb1(lb1id, 2) = xingm(i, 2)
       lb1id = lb1id + 1

      Case Is < 3000
       lb2(lb2id, 1) = xingm(i, 1)
       lb2(lb2id, 2) = xingm(i, 2)
       lb2id = lb2id + 1
'
      Case Else
       lb3(lb3id, 1) = xingm(i, 1)
       lb3(lb3id, 2) = xingm(i, 2)
       lb3id = lb3id + 1
  End Select
Next


Range("D3").Resize(lb1max, 1) = Application.Index(lb1, 0, 1)
Range("E3").Resize(lb1max, 1) = Application.Index(lb1, 0, 2)

Range("F3").Resize(lb2max, 1) = Application.Index(lb2, 0, 1)
Range("G3").Resize(lb2max, 1) = Application.Index(lb2, 0, 2)

Range("H3").Resize(lb3max, 1) = Application.Index(lb3, 0, 1)
Range("I3").Resize(lb3max, 1) = Application.Index(lb3, 0, 2)

End Sub


【课时一作业】工资分类.zip (22 Bytes, 下载次数: 16)

点评

wcymiss
不对哦，这个没有动态。  发表于 2011-12-20 08:47

评分

参与人数 1 +5 收起 理由
wcymiss + 5

查看全部评分

回复

使用道具 举报

下一页 »
12345下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-5-2 14:55 , Processed in 0.962188 second(s), 21 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表