11月13/14日 零基础学Excel VBA 300集Office 2010微视频教程
10月18/19日 7天Excel脱白 高效办公必会的Office实战技巧
10月23/24日 财务会计玩转Excel 网易云课堂-Excel数据透视表应用大全
Excel数据处理与分析实战技巧第1季
查看: 336|回复: 14

VBA实战开发第四期-第六课作业贴

[复制链接]
发表于 2017-9-2 16:37:06 | 显示全部楼层 |阅读模式
本帖最后由 唐伯狼 于 2017-9-13 09:53 编辑

VBA实战开发第四期-第六课作业贴
回复

使用道具 举报

发表于 2017-9-2 17:48:46 | 显示全部楼层
本帖最后由 抬头苦干 于 2017-9-3 16:15 编辑

实战作业06:(2017-09-02 安冬-UID:1700565)
  1. Option Explicit

  2. '作业1:根据出勤记录按月统计各员工出勤次数
  3. Sub Ex01_OnDuty()
  4.     Dim names As Object, dates As Object, arr, brr, i&, j&, k&, iKey
  5.     Set names = CreateObject("Scripting.Dictionary")
  6.     Set dates = CreateObject("Scripting.Dictionary")
  7.     Sheets("出勤统计").Activate
  8.     [A1].CurrentRegion.Offset(1, 2).ClearContents
  9.     '1.生成横向索引
  10.     arr = Range([C1], [C1].End(xlToRight)).Value
  11.     For i = 1 To UBound(arr, 2)
  12.         names(Trim(arr(1, i))) = i
  13.     Next i
  14.     '2.生成纵向索引
  15.     arr = [A1].CurrentRegion.Columns("A:B").Offset(1).Value
  16.     For i = 1 To UBound(arr) - 1
  17.         iKey = Trim(arr(i, 1)) & "|" & Trim(arr(i, 2))
  18.         dates(iKey) = i
  19.     Next i
  20.     ReDim brr(1 To dates.Count, 1 To names.Count)
  21.     '3.读取源数据逐一匹配计数
  22.     arr = Sheets("员工出勤").[A1].CurrentRegion.Offset(1).Value
  23.     For k = 1 To UBound(arr) - 1
  24.         iKey = Year(Trim(arr(k, 1))) & "|" & Month(Trim(arr(k, 1)))
  25.         i = dates(iKey)
  26.         j = names(Trim(arr(k, 3)))
  27.         brr(i, j) = brr(i, j) + 1
  28.         j = names(Trim(arr(k, 4)))
  29.         brr(i, j) = brr(i, j) + 1
  30.     Next k
  31.     [C2].Resize(UBound(brr), UBound(brr, 2)) = brr
  32.     Erase arr, brr
  33.     Set names = Nothing
  34.     Set dates = Nothing
  35. End Sub
复制代码
  1. '作业2:批量分类手机型号
  2. Sub Ex02_BrandClassification()
  3.     Dim types As New Dictionary
  4.     Dim arr, brr, crr, iKey, i&, j&, flag&, x&, y&, z&, ef@
  5.     ef = Timer
  6.     Debug.Print ef
  7.     Application.ScreenUpdating = False
  8.     With Sheets("手机型号分类")
  9.         arr = .[A1].CurrentRegion.Offset(1).Value
  10.         For i = 1 To UBound(arr) - 1
  11.             types(UCase(Trim(arr(i, 1)))) = ""
  12.         Next i
  13.         arr = .Range(.[G2], .[G2].End(xlDown)).Value
  14.         brr = .Range(.[H2], .[H2].End(xlDown)).Value
  15.         ReDim crr(1 To types.Count, 1 To 3)
  16.         x = 0
  17.         y = 0
  18.         z = 0
  19.         For Each iKey In types
  20.             flag = 3
  21.             For i = 1 To UBound(arr)
  22.                 If iKey Like ("*" & UCase(Trim(arr(i, 1))) & "*") Then
  23.                     flag = 1
  24.                     Exit For
  25.                 End If
  26.             Next i
  27.             If flag = 3 Then
  28.                 For j = 1 To UBound(brr)
  29.                     If InStr(iKey, UCase(Trim(brr(j, 1)))) Then
  30.                         flag = 2
  31.                         Exit For
  32.                     End If
  33.                 Next j
  34.             End If
  35.             If flag = 1 Then
  36.                 x = x + 1
  37.                 crr(x, flag) = iKey
  38.             ElseIf flag = 2 Then
  39.                 y = y + 1
  40.                 crr(y, flag) = iKey
  41.             Else
  42.                 z = z + 1
  43.                 crr(z, flag) = iKey
  44.             End If
  45.         Next iKey
  46.         .[C2].CurrentRegion.Offset(1).ClearContents
  47.         .[C2].Resize(UBound(crr), UBound(crr, 2)) = crr
  48.     End With
  49.     Erase arr, brr, crr
  50.     types.RemoveAll
  51.     MsgBox (Timer - ef) & " s"
  52.     Application.ScreenUpdating = True
  53. End Sub
复制代码
  1. '作业3:同时按班级和小组统计考试各分数段人数
  2. Sub Ex03_ExamStatistics()
  3.     Dim lvs1 As New Dictionary
  4.     Dim lvs2 As New Dictionary
  5.     Dim clss As New Dictionary
  6.     Dim arr, brr1, brr2, i&, j&, k&, iKey, iCls$, iGrp$, iScr&, found&, t!
  7.     t = Timer
  8.     Application.ScreenUpdating = False
  9.         '1.建横向索引
  10.         Sheets("班级分数段统计").Activate
  11.         brr1 = [B2:M2].Value
  12.         brr2 = [B30:M30].Value
  13.         For i = 1 To UBound(brr1, 2)
  14.             lvs1(brr1(1, i)) = i
  15.             lvs2(brr2(1, i)) = i
  16.         Next i
  17.         '2.建纵向索引
  18.         arr = [A3:A24].Value
  19.         For i = 1 To UBound(arr)
  20.             clss(arr(i, 1)) = i
  21.         Next i
  22.         '3.建结果数组并初始化
  23.         ReDim brr1(1 To clss.Count + 3, 1 To lvs1.Count + 1)
  24.         ReDim brr2(1 To clss.Count + 3, 1 To lvs2.Count + 1)
  25.         For i = 1 To UBound(brr1)
  26.             For j = 1 To UBound(brr1, 2)
  27.                 brr1(i, j) = 0
  28.                 brr2(i, j) = 0
  29.             Next j
  30.         Next i
  31.         '4.锁定结果数组元素位置并计数
  32.         arr = Sheets("总表").[A1].CurrentRegion.Offset(2).Value
  33.         For k = 1 To UBound(arr) - 2
  34.             iCls = arr(k, 4)    '当前班级
  35.             iGrp = arr(k, 3)    '当前小组
  36.             iScr = arr(k, 13)   '该生成绩
  37.             '确定行坐标 i
  38.             For Each iKey In clss
  39.                 If iCls = Split(Trim(iKey), " ")(0) Then
  40.                     i = clss(iKey)
  41.                     Exit For
  42.                 End If
  43.             Next
  44.             '确定列坐标 j
  45.             found = 0
  46.             Call Find_Index_J(lvs1, iKey, iScr, found, j, 1)
  47.             If Not found Then _
  48.                 Call Find_Index_J(lvs2, iKey, iScr, found, j, 2)
  49.             '根据 i、j 累加到指定位置
  50.             If found = 1 Then
  51.                 Call FillArray(brr1, i, j, iGrp, clss)
  52.             Else
  53.                 Call FillArray(brr2, i, j, iGrp, clss)
  54.             End If
  55.         Next k
  56.         '5.显示结果
  57.         [B3:N27,B31:N55].ClearContents
  58.         [B3].Resize(UBound(brr1), UBound(brr1, 2)) = brr1
  59.         [B31].Resize(UBound(brr2), UBound(brr2, 2)) = brr2
  60.         Erase arr, brr1, brr2
  61.         lvs1.RemoveAll
  62.         lvs2.RemoveAll
  63.         clss.RemoveAll
  64.         MsgBox "用时 " & Format(Timer - t, "0.000000") & " s", vbInformation
  65.     Application.ScreenUpdating = True
  66. End Sub
  67. '子过程1:确定列标 j
  68. Private Sub Find_Index_J(dicToLookup As Dictionary, iKey, myScore&, found&, j&, valueOnFound&)
  69.     Dim Max&, Min&
  70.     For Each iKey In dicToLookup
  71.         Select Case Right(iKey, 1)
  72.             Case "上"
  73.                 Min = Left(iKey, 3):                Max = 950
  74.             Case "下"
  75.                 Min = 0:                            Max = Left(iKey, 3)
  76.             Case "分"
  77.                 Min = Left(iKey, 3):                Max = Mid(iKey, 5, 3)
  78.         End Select
  79.         If (myScore - Max) * (myScore - Min) <= 0 Then
  80.             j = dicToLookup(iKey)
  81.             found = valueOnFound
  82.             Exit For
  83.         End If
  84.     Next
  85. End Sub
  86. '子过程2:向对应的结果数组填数
  87. Private Sub FillArray(brr, i&, j&, iGroup$, dic As Dictionary)
  88.     Dim iRow&
  89.     iRow = 0
  90.     Select Case iGroup
  91.         Case "1组":            iRow = dic.Count + 1
  92.         Case "2组":            iRow = dic.Count + 2
  93.         Case Else:             iRow = dic.Count + 3
  94.     End Select
  95.     brr(i, j) = brr(i, j) + 1                                   '各班级、各分数段计数
  96.     brr(iRow, j) = brr(iRow, j) + 1                             '各小组、各分数段计数
  97.     brr(i, UBound(brr, 2)) = brr(i, UBound(brr, 2)) + 1         '各班级、全分数段计数
  98.     brr(iRow, UBound(brr, 2)) = brr(iRow, UBound(brr, 2)) + 1   '各小组、全分数段计数
  99. End Sub
复制代码
  1. '作业4:录取志愿填报统计
  2. Sub Ex04_EnrollmentPlan()
  3.     Dim dicPlan As Object:    Set dicPlan = CreateObject("Scripting.Dictionary")
  4.     Dim dicReal As Object:    Set dicReal = CreateObject("Scripting.Dictionary")
  5.     Dim dicLine As Object:    Set dicLine = CreateObject("Scripting.Dictionary")
  6.     Dim arr, i&, iScr&, iPlans$, n&, done As Boolean, iKey, t
  7.     t = Timer
  8.     Application.ScreenUpdating = False
  9.         Sheets("录取学校").Activate
  10.         [F2].Resize([A1].CurrentRegion.Rows.Count - 1, 1).ClearContents
  11.         [H1].CurrentRegion.Offset(1, 2).ClearContents
  12.         arr = [H1].CurrentRegion.Offset(1).Value
  13.         For i = 1 To UBound(arr) - 1
  14.             dicPlan(arr(i, 1)) = arr(i, 2)
  15.             dicReal(arr(i, 1)) = 0
  16.             dicLine(arr(i, 1)) = 0
  17.         Next i
  18.         arr = [A1].CurrentRegion.Offset(1).Value
  19.         For i = 1 To UBound(arr) - 1
  20.             iScr = arr(i, 4)
  21.             iPlans = arr(i, 5)
  22.             done = False
  23.             If Len(iPlans) < 3 Then
  24.                 arr(i, 6) = "无效填报"
  25.             ElseIf Len(Trim(iPlans)) Mod 2 Then
  26.                 n = 2
  27.                 Do Until done Or n > Len(iPlans)
  28.                     For Each iKey In dicPlan
  29.                         If Right(iKey, 2) = Mid(iPlans, n, 2) Then
  30.                             If dicReal(iKey) < dicPlan(iKey) Then
  31.                                 done = True
  32.                                 dicReal(iKey) = dicReal(iKey) + 1
  33.                                 arr(i, 6) = iKey
  34.                                 dicLine(iKey) = iScr
  35.                             ElseIf iScr = dicLine(iKey) Then
  36.                                 done = True
  37.                                 dicReal(iKey) = dicReal(iKey) + 1
  38.                                 arr(i, 6) = iKey
  39.                             End If
  40.                         End If
  41.                         If done Then Exit For
  42.                     Next iKey
  43.                     If done Then Exit Do
  44.                     n = n + 2
  45.                 Loop
  46.             End If
  47.             If (Not done) And (Len(arr(i, 6)) = 0) Then arr(i, 6) = "未被指定学校录取"
  48.         Next i
  49.         [A2].Resize(UBound(arr) - 1, UBound(arr, 2)) = arr
  50.         [J2].Resize(dicReal.Count, 2) = WorksheetFunction.Transpose(Array(dicReal.Items, dicLine.Items))
  51.         Erase arr
  52.         dicPlan.RemoveAll
  53.         dicReal.RemoveAll
  54.         dicLine.RemoveAll
  55.         MsgBox "统计完成,用时 " & Format(Timer - t, "0.0000") & " 秒", vbInformation
  56.     Application.ScreenUpdating = True
  57. End Sub
复制代码


回复 支持 反对

使用道具 举报

发表于 2017-9-3 09:59:53 | 显示全部楼层
  1. Sub 作业1员工出勤表()
  2.    
  3.     Dim i As Object, arr(), 行 As Long
  4.     Dim brr(), crr(), 列 As Long
  5.    
  6.     Set i = CreateObject("scripting.dictionary")
  7.     Worksheets("出勤统计").Activate '激活出勤统计表
  8.    
  9.     arr = Worksheets("员工出勤").Range("A1").CurrentRegion.Value '将员工出勤 的数据写入数据
  10.     brr = Range("c1:G1") '表格已有姓名,直接引用
  11.    
  12.     For 列 = 1 To UBound(brr, 2) '循环每一列
  13.         
  14.         i(brr(1, 列)) = 列
  15.    
  16.     Next
  17.     Rem 上面的循环将每个关键字(姓名)对应该的项目标序。
  18.     Erase brr '清空brr
  19.     brr = Range(Range("a2"), Range("b1").End(xlDown)).Value
  20.     Rem 将年份和日期写入数组
  21.     For 行 = 1 To UBound(brr) '循环每一行
  22.         
  23.         i(brr(行, 1) & brr(行, 2)) = 行 '将年份和月份连接起来并标记序号
  24.    
  25.     Next
  26.    
  27.     Erase brr '清空brr
  28.     ReDim crr(1 To Range("A1").End(xlDown).Row - 1, 1 To 5) '定义crr的大小。
  29.    
  30.     For 行 = 2 To UBound(arr) '循环每一行
  31.         
  32.         crr(i(Year(arr(行, 1)) & Month(arr(行, 1))), i(arr(行, 3))) = crr(i(Year(arr(行, 1)) _
  33.         & Month(arr(行, 1))), i(arr(行, 3))) + 1
  34.         Rem 年月、姓名所对应的序号作为数组的行列。
  35.         
  36.         crr(i(Year(arr(行, 1)) & Month(arr(行, 1))), i(arr(行, 4))) = crr(i(Year(arr(行, 1)) _
  37.         & Month(arr(行, 1))), i(arr(行, 4))) + 1
  38.         Rem 数据表中有两列数据需要统计,所以写两行代码分别统计
  39.     Next
  40.    
  41.     Range("c2").Resize(UBound(crr), 5) = crr '将数组写入单元格

  42. End Sub
复制代码
  1. Sub 数组字典作业品牌拆分()
  2.    
  3.     Dim i As Object, arr(), 行 As Long, 辅助, count As Long
  4.     Dim brr(), 列 As Long, crr(), row As Long
  5.    
  6.     Set i = CreateObject("scripting.dictionary")
  7.     arr = Range("a2:a" & Range("A1").End(xlDown).row).Value
  8.     Rem 将数据写入数组
  9.     For 行 = 1 To UBound(arr)
  10.         
  11.         i(arr(行, 1)) = ""
  12.         '将品牌设置字关键字,并取唯一值
  13.     Next
  14.     brr = Range("G1").CurrentRegion.Value '将手机分类的标准写入数组
  15.    
  16.     ReDim crr(1 To i.count, 1 To 2) '定义crr数组,行为非重复品牌的数量,两列
  17.         
  18.     For Each 辅助 In i '遍历字典
  19.             
  20.         For 行 = 1 To UBound(brr) '设置行
  21.                
  22.             For 列 = 1 To UBound(brr, 2) '设置列
  23.   
  24.                 If brr(行, 列) <> "" Then '如果需要处理的数据为空,则不处理
  25.                         
  26.                     If InStr(辅助, brr(行, 列)) Then '判断当前处理的关键字中是否包括当前处理的品牌标准
  27.   
  28.                         If 列 = 1 Then '判断第几列。
  29.   
  30.                             row = row + 1 '增加一行
  31.                             crr(row, 列) = 辅助 '将品牌全称写入数组
  32.                             i.Remove (辅助) '删除已经处理了的数组
  33.    
  34.                         Else '此数据只有两列
  35.                                 
  36.                             count = count + 1 '增加一行
  37.                             crr(count, 列) = 辅助 '将品牌全称写入数组
  38.                             i.Remove (辅助) '删除 已经处理的数组

  39.                         End If
  40.                         
  41.                     End If
  42.                     
  43.                 End If

  44.             Next
  45.             
  46.         Next
  47.          
  48.     Next

  49.     Range("C2").Resize(UBound(crr), UBound(crr, 2)) = crr '将贸易机和国产大牌的名称写入单元格
  50.     Range("E2").Resize(i.count) = WorksheetFunction.Transpose(i.keys) '将其他品牌写入单元格

  51. End Sub
复制代码

  1. Sub 数组字典毕业之作()
  2.    
  3.     Dim i As Object, arr(), 行 As Long, brr(), j
  4.     Dim crr(), 辅助 As String, 列 As Long, a As Date, b As Date
  5.     a = Time
  6.     Set i = CreateObject("scripting.dictionary")
  7.    
  8.     With Worksheets("总表")
  9.         arr = .Range("c2:M" & .UsedRange.Rows.Count).Value
  10.     End With '将需要处理的数据写入数组
  11.    
  12.     Worksheets("班级分数段统计").Activate '激活班级分数段统计表格。
  13.     brr = Range("A3:A27").Value '将班级写入数组
  14.    
  15.     For 行 = 1 To UBound(brr) '循环每一行
  16.         
  17.         If InStr(Trim(brr(行, 1)), "班") <> 0 Then '如果包含班
  18.             i(Left(Trim(brr(行, 1)), InStr(Trim(brr(行, 1)), "班"))) = 行
  19.         
  20.         ElseIf InStr(Trim(brr(行, 1)), "组") <> 0 Then '如果包含组
  21.             i(Left(Trim(brr(行, 1)), InStr(Trim(brr(行, 1)), "组"))) = 行
  22.    
  23.         Else '不包含班又不包含组(包含部的数据)。
  24.             i(Left(Trim(brr(行, 1)), InStr(Trim(brr(行, 1)), "部"))) = 行
  25.    
  26.         End If
  27.         '将每个班或组(部)分别写入字典,关键字为班级或组(部)的名称,项目为其在数据区域对应的行号。
  28.     Next
  29.       
  30.     Erase brr '清空brr数组
  31.     crr = Range([b30], [b30].End(xlToRight)).Value
  32.     brr = Range(Range("b2"), [b2].End(xlToRight)).Value
  33.     '将两个答案区域的分数段分别写入brr和crr。因为两个区域的班级顺序都是一样的,所以只处理一个。
  34.     For 列 = 1 To UBound(brr, 2) '循环每一列,crr和brr的列相同,此处上标写crr 也可以
  35.         
  36.         i(Left(Trim(brr(1, 列)), 3)) = 列 '总分没有少于3位数或大于3位数的,所以提取前三位数字
  37.         i(Left(Trim(crr(1, 列)), 3)) = 列
  38.         '将两个答案区域的分数段分别写入字典,关键字为分数段中最大的分数值,项为其对应的列号。
  39.     Next
  40.    
  41.     Erase brr '清空brr
  42.     Erase crr '清空crr
  43.     '重新设置brr与crr的大小,其范围为答案区域的大小。
  44.     ReDim brr(1 To Range("A2").End(xlDown).Row - 2, 1 To Range("A2").End(xlToRight).Column - 1)
  45.     ReDim crr(1 To Range("A30").End(xlDown).Row - 30, 1 To Range("A30").End(xlToRight).Column - 1)
  46.     i("0") = 12
  47.     '后面用工作表函数值时,小于400的分数,会返回文本0,所以先将文本0增加到字典中,并将项设为12
  48.     For 行 = 2 To UBound(arr) '循环每一行

  49.         辅助 = Evaluate("=lookup(" & arr(行, 11) & ", {0,400,420,440,460,480," _
  50.         & "500,520,540,560,580,600,620,640,660,680,700,720,740,760,780,800,850,900})")
  51.         '利用工作表函数lookup将分数返回为其分数段对应的上限。方便字典查找
  52.         If 辅助 >= 620 Then '如果大于等于620,则将数据计算为第一个答案区域的值。
  53.             
  54.             brr(i(arr(行, 2)), i(辅助)) = brr(i(arr(行, 2)), i(辅助)) + 1 '统计各班级和对应的分数段的人数
  55.             brr(i(arr(行, 2)), UBound(brr, 2)) = brr(i(arr(行, 2)), UBound(brr, 2)) + 1 '统计各班级人数
  56.             brr(i(arr(行, 1)), i(辅助)) = brr(i(arr(行, 1)), i(辅助)) + 1 '统计组(部)和对应的分数段的人数
  57.             brr(i(arr(行, 1)), 13) = brr(i(arr(行, 1)), 13) + 1 '分别 统计各组(部)对应的总人数
  58.         
  59.         Else '如果小于620,则将数据计算为第二个答案区域的值。
  60.             
  61.             crr(i(arr(行, 2)), i(辅助)) = crr(i(arr(行, 2)), i(辅助)) + 1
  62.             crr(i(arr(行, 2)), UBound(crr, 2)) = crr(i(arr(行, 2)), UBound(crr, 2)) + 1
  63.             crr(i(arr(行, 1)), i(辅助)) = crr(i(arr(行, 1)), i(辅助)) + 1
  64.             crr(i(arr(行, 1)), 13) = crr(i(arr(行, 1)), 13) + 1
  65.             'crr(第二区域)的计算规则 和brr(第一区域)的计算规则 一样
  66.         End If
  67.     Next
  68.       
  69.     Range("b3").Resize(UBound(brr), UBound(brr, 2)) = brr '将第一答案区域写入单元格
  70.     Range("b31").Resize(UBound(crr), UBound(crr, 2)) = crr '将第二答案区域写入单元格
  71.     b = Time - a
  72.     MsgBox b
  73. End Sub
复制代码
  1. Sub 平等志愿录取分数优先()
  2.    
  3.     Dim i As Object, arr(), 行 As Long, 辅助 As Long, brr(), crr()
  4.    
  5.     Set i = CreateObject("scripting.dictionary")
  6.     arr = Range("h2:H" & [h2].End(xlDown).Row).Value '将学校代码写入数组
  7.    
  8.     For 行 = 1 To UBound(arr) '循环arr中的每一行
  9.         
  10.         i(Right(arr(行, 1), 2)) = 行 '标记学校代码的行号,并且关键字取后两位
  11.    
  12.     Next
  13.    
  14.     Erase arr '清空arr
  15.     arr = Range("a1:E" & [a1].End(xlDown).Row).Value '将学生的考试成绩及其他信息写入数组
  16.    
  17.     ReDim brr(1 To i.Count, 1 To 2) '定义brr数组,用于存储实际录取人数与最低录取分数线
  18.     ReDim crr(1 To UBound(arr)) '定义crr数组,用于存储每位学生所被录取的学校代码
  19.    
  20.     For 行 = 2 To UBound(arr) '循环每一行
  21.   
  22.         If Len(arr(行, 5) < 3) Then '如果学生没有填写一个志愿,则不处理
  23.             
  24.             For 辅助 = 2 To Len(arr(行, 5)) - 1 Step 2 '用于提取学生志愿 中的学校代码
  25.                
  26.                 If i.exists(Mid(arr(行, 5), 辅助, 2)) Then '如果当前提取的学校代码在需要处理的学校代码中
  27.   
  28.                     If brr(i(Mid(arr(行, 5), 辅助, 2)), 1) <= Range("I" & i(Mid(arr(行, 5), 辅助, 2)) + 1).Value _
  29.                     Or brr(i(Mid(arr(行, 5), 辅助, 2)), 2) = arr(行, 4) Then
  30.                     '如果当前学校录取的实际人数小于等于计划录取的人数,或者学生成绩等于分数线,则处理。
  31.                         brr(i(Mid(arr(行, 5), 辅助, 2)), 1) = brr(i(Mid(arr(行, 5), 辅助, 2)), 1) + 1 '学校录取人数增加1
  32.                         crr(行 - 1) = "p" & i.keys()(i(Mid(arr(行, 5), 辅助, 2)) - 1) '将录取 学校的代码写入数组
  33.                         
  34.                     If brr(i(Mid(arr(行, 5), 辅助, 2)), 1) = Range("I" & i(Mid(arr(行, 5), 辅助, 2)) + 1) Then
  35.                         '如果实际人数等于计划录取人数时,则将录取分数线写入数组
  36.                         brr(i(Mid(arr(行, 5), 辅助, 2)), 2) = arr(行, 4)
  37.   
  38.                     End If
  39.   
  40.                     Exit For '当学生被录取后,退出循环
  41.                     
  42.                     End If
  43.                
  44.                 End If
  45.   
  46.             Next
  47.         
  48.         End If
  49.    
  50.     Next
  51.    
  52.     Range("F2").Resize(UBound(crr)) = WorksheetFunction.Transpose(crr) '将学校代码写入单元格
  53.     Range("j2").Resize(i.Count, 2) = brr '将学校的录取人数和分数线写入单元格

  54. End Sub
复制代码




回复 支持 反对

使用道具 举报

发表于 2017-9-3 14:32:10 | 显示全部楼层
感觉字典和数组的使用比以前熟练多了

VBA实战开发第四期_第六课作业_449372956(JSON).zip

836.81 KB, 下载次数: 0

QQ:449372956

回复 支持 反对

使用道具 举报

发表于 2017-9-5 10:28:42 | 显示全部楼层
Sub 出勤统计()
Dim arr, brr, crr, drr, i As Long, j As Long, key
Dim dic As New Dictionary, eic As New Dictionary
Dim x As Integer, y As Integer
arr = Sheet2.Range("a1").CurrentRegion
ReDim brr(1 To UBound(arr), 1 To 5)
'写入行坐标
For i = 2 To UBound(arr)
    dic(Year(arr(i, 1)) & "," & Month(arr(i, 1))) = ""
Next
crr = WorksheetFunction.Transpose(dic.Keys)
ReDim drr(1 To UBound(crr), 1 To 2)
For i = 1 To UBound(crr)
    drr(i, 1) = Split(crr(i, 1), ",")(0)
    drr(i, 2) = Split(crr(i, 1), ",")(1)
Next
Sheet1.Range("a2").Resize(UBound(drr), UBound(drr, 2)) = drr

'写入列坐标
For i = 2 To UBound(arr)
    For j = 3 To UBound(arr, 2)
        eic(Trim(arr(i, j))) = ""
    Next
Next
Sheet1.Range("c1").Resize(1, eic.Count) = eic.Keys

'行坐标转化为数字
i = 1
For Each key In dic
    dic(key) = i
    i = i + 1
Next
'列坐标转化为数字
j = 1
For Each key In eic
    eic(key) = j
    j = j + 1
Next

'使用下棋法进行累加
For i = 2 To UBound(arr)
    For j = 3 To UBound(arr, 2)
        x = dic(Year(arr(i, 1)) & "," & Month(arr(i, 1)))
        y = eic(arr(i, j))
        brr(x, y) = brr(x, y) + 1
    Next
Next
Sheet1.Range("c2").Resize(UBound(brr), UBound(brr, 2)) = brr

End Sub

vba进阶第4期 闪电拳手
回复 支持 反对

使用道具 举报

发表于 2017-9-5 11:40:34 | 显示全部楼层
Sub 数组字典作业品牌拆分()
Dim arr, brr, crr, drr, err, i As Integer, j As Integer
Dim dic As New Dictionary, k As Integer
'生成不重复的型号
arr = Sheet1.Range("a1").CurrentRegion
For i = 2 To UBound(arr)
    dic(arr(i, 1)) = ""
Next
brr = WorksheetFunction.Transpose(dic.Keys)

crr = Sheet1.Range("g1").CurrentRegion
'写入国产大牌机
ReDim drr(1 To UBound(arr))
k = 0
For i = 2 To UBound(crr)
    For j = 1 To UBound(brr)
        If brr(j, 1) Like crr(i, 2) & "*" Then
            k = k + 1
            drr(k) = brr(j, 1)
        End If
    Next
Next
Sheet1.Range("d2").Resize(UBound(drr)) = WorksheetFunction.Transpose(drr)

'写入贸易机
ReDim err(1 To UBound(arr))
k = 0
For i = 2 To UBound(crr)
    For j = 1 To UBound(brr)
        If crr(i, 1) <> "" Then
            If brr(j, 1) Like crr(i, 1) & "*" Then
                k = k + 1
                err(k) = brr(j, 1)
            End If
        End If
    Next
Next
Sheet1.Range("c2").Resize(UBound(err)) = WorksheetFunction.Transpose(err)

'写入其它品牌之移出国产大牌机
For i = 1 To UBound(drr)
    If dic.Exists(drr(i)) Then
        dic.Remove (drr(i))
    End If
Next
'写入其它品牌之移出贸易机
For i = 1 To UBound(err)
    If dic.Exists(err(i)) Then
        dic.Remove (err(i))
    End If
Next
Sheet1.Range("e2").Resize(dic.Count) = WorksheetFunction.Transpose(dic.Keys)
End Sub

vba进阶班4期  闪电拳手
回复 支持 反对

使用道具 举报

发表于 2017-9-5 14:49:25 | 显示全部楼层
Sub EmployeeAttendance() '正式课6作业--员工出勤表

    Dim dicN As New Dictionary
    Dim dicP As New Dictionary
    Dim arr, arrN, arrP, brr, i&, j&, key
    arr = Worksheets("员工出勤").[a1].CurrentRegion
    For i = 2 To UBound(arr, 1)
        If arr(i, 1) <> "" Then
            dicP(Year(arr(i, 1)) & "," & Month(arr(i, 1))) = ""
        End If
        For j = 3 To UBound(arr, 2)
            If arr(i, j) <> "" Then dicN(arr(i, j)) = ""
        Next
    Next
   
    ReDim arrN(1 To 1, 1 To dicN.Count)
    i = 1
    For Each key In dicN
        dicN(key) = i
        arrN(1, i) = key
        i = i + 1
    Next
    Worksheets("出勤统计").[C1].Resize(1, dicN.Count) = arrN
    ReDim arrP(1 To dicP.Count, 1 To 2)
    i = 1
    For Each key In dicP
        dicP(key) = i
        arrP(i, 1) = Split(key, ",")(0)
        arrP(i, 2) = Split(key, ",")(1)
        i = i + 1
    Next
    Worksheets("出勤统计").[A2].Resize(UBound(arrP, 1), 2) = arrP
    ReDim brr(1 To dicP.Count, 1 To dicN.Count)

    For i = 2 To UBound(arr, 1)
        For j = 3 To UBound(arr, 2)
            brr(dicP(Year(arr(i, 1)) & "," & Month(arr(i, 1))), dicN(arr(i, j))) = brr(dicP(Year(arr(i, 1)) & "," & Month(arr(i, 1))), dicN(arr(i, j))) + 1
        Next
    Next
    Worksheets("出勤统计").[C2].Resize(UBound(brr, 1), UBound(brr, 2)) = brr

End Sub
回复 支持 反对

使用道具 举报

发表于 2017-9-5 15:22:38 | 显示全部楼层
  1. Sub 员工出勤表()
  2.     Dim dic As New Dictionary, dic1 As New Dictionary, arr, brr, i As Long, j As Long
  3.     arr = Sheets("出勤统计").[a1].CurrentRegion
  4.     For i = 1 To UBound(arr) - 1
  5.         dic(arr(i + 1, 1) & arr(i + 1, 2)) = i
  6.     Next
  7.     For j = 1 To UBound(arr, 2) - 2
  8.         dic1(arr(1, j + 2)) = j
  9.     Next
  10.     Sheets("员工出勤").Activate
  11.     Erase arr
  12.     arr = [a1].CurrentRegion
  13.     ReDim brr(1 To dic.Count, 1 To dic1.Count)
  14.     For i = 2 To UBound(arr)
  15.         For j = 3 To 4
  16.             brr(dic(Year(arr(i, 1)) & Month(arr(i, 1))), dic1(arr(i, j))) = brr(dic(Year(arr(i, 1)) & Month(arr(i, 1))), dic1(arr(i, j))) + 1
  17.         Next
  18.     Next
  19.     Sheets("出勤统计").Activate
  20.     [c2].Resize(UBound(brr), UBound(brr, 2)) = brr
  21. End Sub

复制代码





  1. Sub 品牌拆分()
  2.     Dim dic As New Dictionary, dic1 As New Dictionary, arr, i As Long, j As Long, key, brr
  3.     arr = [a1].CurrentRegion
  4.     ReDim brr(1 To UBound(arr), 1 To 3)
  5.     For i = 2 To UBound(arr)
  6.         dic(arr(i, 1)) = arr(i, 1)
  7.     Next
  8.     Erase arr
  9.     arr = [g1].CurrentRegion
  10.     Dim x As Long, y As Long, z As Long
  11.     x = 1
  12.     y = 1
  13.     z = 1
  14.    
  15.     For Each key In dic
  16.         i = 1
  17.         j = 1
  18.         Do Until (key Like "*" & arr(i, j) & "*" = True And arr(i, j) <> "") Or (i = UBound(arr) And j = UBound(arr, 2))
  19.         If i = UBound(arr) Then
  20.             i = 1
  21.             j = j + 1
  22.         Else
  23.             i = i + 1
  24.         End If
  25.         Loop
  26.         If key Like "*" & arr(i, j) & "*" = True Then
  27.             If j = 1 Then
  28.                 brr(x, j) = dic(key)
  29.                 x = x + 1
  30.             Else
  31.                 brr(y, j) = dic(key)
  32.                 y = y + 1
  33.             End If
  34.         Else
  35.             brr(z, 3) = dic(key)
  36.             z = z + 1
  37.         End If
  38.     Next
  39.     [c2].Resize(UBound(brr), UBound(brr, 2)) = brr
  40. End Sub
复制代码




  1. Sub 平行志愿()
  2.     Dim dic As New Dictionary, dic1 As New Dictionary, dic2 As New Dictionary, arr, brr, crr, i As Long, n As Long, j As Long, m As Long
  3.     t = Timer
  4.     arr = [a1].CurrentRegion
  5.     crr = [h1].CurrentRegion
  6.     For i = 2 To UBound(arr)
  7.         ReDim brr(1 To 5)
  8.         n = 1
  9.         For j = 2 To Len(arr(i, 5)) - 1 Step 2
  10.                 brr(n) = "P" & Mid(arr(i, 5), j, 2)
  11.             n = n + 1
  12.         Next
  13.         arr(i, 5) = brr
  14.         Erase brr
  15.     Next
  16.     Erase brr
  17.     For i = 2 To UBound(crr)
  18.         dic(crr(i, 1)) = crr(i, 2)
  19.     Next
  20.     For i = 2 To UBound(arr)
  21.         For n = 1 To 5
  22.             If dic.Exists(arr(i, 5)(n)) = True Then
  23.                 If dic(arr(i, 5)(n)) > dic1(arr(i, 5)(n)) Or arr(i, 4) = dic2(arr(i, 5)(n)) Then
  24.                     dic1(arr(i, 5)(n)) = dic1(arr(i, 5)(n)) + 1
  25.                     dic2(arr(i, 5)(n)) = arr(i, 4)
  26.                     arr(i, 6) = arr(i, 5)(n)
  27.                     Exit For
  28.                 End If
  29.             End If
  30.         Next
  31.     Next
  32.     Erase brr
  33.     ReDim brr(1 To UBound(arr))
  34.     For i = 1 To UBound(arr)
  35.         brr(i) = arr(i, 6)
  36.     Next
  37.     For i = 2 To UBound(crr)
  38.         crr(i, 3) = dic1(crr(i, 1))
  39.         crr(i, 4) = dic2(crr(i, 1))
  40.     Next
  41.     [f1].Resize(UBound(brr), 1) = WorksheetFunction.Transpose(brr)
  42.     [h1].Resize(UBound(crr), UBound(crr, 2)) = crr
  43. End Sub
复制代码




  1. Sub 成绩统计()
  2.     Dim arr, brr1, brr2, i&, j&, dic As Object, dic1 As Object, dic2 As Object, score&, key
  3.     Set dic = CreateObject("scripting.dictionary")
  4.     Set dic1 = CreateObject("scripting.dictionary")
  5.     Set dic2 = CreateObject("scripting.dictionary")
  6.     arr = Sheets("参数表").[a1].CurrentRegion
  7.     For i = 3 To UBound(arr)
  8.         dic(arr(i, 1) & "班") = arr(i, 11)    '班主任
  9.         dic2(arr(i, 1) & "班" & " " & arr(i, 11)) = arr(i, 2)
  10.     Next
  11.     score = 400
  12.     i = 1
  13.     Do Until score > 800
  14.         dic1(i) = score                   '分数段
  15.         i = i + 1
  16.         score = score + 20
  17.     Loop
  18.         dic1(i) = 850
  19.         dic1(i + 1) = 900
  20.     Erase arr
  21.     arr = Sheets("总表").[a1].CurrentRegion
  22.    
  23.    
  24.     brr1 = Sheets("班级分数段统计").[a1].CurrentRegion     '上面一段
  25.     brr2 = Sheets("班级分数段统计").[a29].CurrentRegion    '下面一段
  26.     For i = 3 To UBound(arr)
  27.         For j = 3 To UBound(brr1)                           '匹配行
  28.             If arr(i, 4) & " " & dic(arr(i, 4)) = brr1(j, 1) Then
  29.             Exit For
  30.             End If
  31.         Next
  32.         If arr(i, 13) <= 400 Then                            '匹配列
  33.             brr2(j, 13) = brr2(j, 13) + 1
  34.             brr2(j, 14) = brr2(j, 14) + 1
  35.         ElseIf arr(i, 13) >= 900 Then
  36.             brr1(j, 2) = brr1(j, 2) + 1
  37.             brr1(j, 14) = brr1(j, 14) + 1
  38.         Else
  39.             For Each key In dic1
  40.                 If arr(i, 13) > dic1(key) And arr(i, 13) <= dic1(key + 1) Then
  41.                     Exit For
  42.                 End If
  43.             Next
  44.             If key >= 12 Then
  45.                 brr1(j, 25 - key) = brr1(j, 25 - key) + 1
  46.                 brr1(j, 14) = brr1(j, 14) + 1
  47.             Else
  48.                 brr2(j, 13 - key) = brr2(j, 13 - key) + 1
  49.                 brr2(j, 14) = brr2(j, 14) + 1
  50.             End If
  51.         End If
  52.     Next
  53.    
  54.    
  55.    
  56.     For i = 2 To UBound(brr1, 2)
  57.         For j = 3 To UBound(brr1) - 3
  58.         If brr1(j, i) = "" Then
  59.             brr1(j, i) = 0
  60.         End If
  61.         If dic2(brr1(j, 1)) = 1 Then
  62.             brr1(UBound(brr1) - 2, i) = brr1(UBound(brr1) - 2, i) + brr1(j, i)
  63.         ElseIf dic2(brr1(j, 1)) = 2 Then
  64.             brr1(UBound(brr1) - 1, i) = brr1(UBound(brr1) - 1, i) + brr1(j, i)
  65.         Else
  66.             brr1(UBound(brr1), i) = brr1(UBound(brr1), i) + brr1(j, i)
  67.         End If
  68.         Next
  69.     Next
  70.    
  71.    
  72.     For i = 2 To UBound(brr2, 2)
  73.         For j = 3 To UBound(brr2) - 3
  74.         If brr2(j, i) = "" Then
  75.             brr2(j, i) = 0
  76.         End If
  77.         If dic2(brr2(j, 1)) = 1 Then
  78.             brr2(UBound(brr2) - 2, i) = brr2(UBound(brr2) - 2, i) + brr2(j, i)
  79.         ElseIf dic2(brr2(j, 1)) = 2 Then
  80.             brr2(UBound(brr2) - 1, i) = brr2(UBound(brr2) - 1, i) + brr2(j, i)
  81.         Else
  82.             brr2(UBound(brr2), i) = brr2(UBound(brr2), i) + brr2(j, i)
  83.         End If
  84.         Next
  85.     Next
  86.     Sheets("班级分数段统计").Activate
  87.     [a1].Resize(UBound(brr1), UBound(brr1, 2)) = brr1
  88.     [a29].Resize(UBound(brr2), UBound(brr2, 2)) = brr2
  89.    
  90.    
  91. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-9-5 19:40:04 | 显示全部楼层
  1. Sub 出勤统计()
  2. '思路:采用下棋法,定义2个字典用来确定目标数组的行和列的位置
  3.     Dim dic1 As New Dictionary, dic2 As New Dictionary
  4.     Dim arr, brr, i As Long
  5.     With Sheets("员工出勤")
  6.         arr = .Range("a1").CurrentRegion
  7.     End With
  8.     For i = 2 To UBound(arr)
  9.         dic1(Year(arr(i, 1)) & "/" & Month(arr(i, 1))) = ""
  10.         dic2(arr(i, 3)) = ""
  11.         dic2(arr(i, 4)) = ""
  12.     Next
  13.     With Sheets("出勤统计")
  14.         .Range("c2:g15").ClearContents
  15.         brr = .[a1].CurrentRegion
  16.     End With
  17.     For i = 2 To UBound(brr)    '用字典键值确定目标数组行的位置
  18.         dic1(brr(i, 1) & "/" & brr(i, 2)) = i
  19.     Next
  20.     For i = 3 To UBound(brr, 2)    '用字典键值确定列的位置
  21.         dic2(brr(1, i)) = i
  22.     Next
  23.     For i = 2 To UBound(arr)
  24.         brr(dic1(Year(arr(i, 1)) & "/" & Month(arr(i, 1))), dic2(arr(i, 3))) = brr(dic1(Year(arr(i, 1)) & "/" & Month(arr(i, 1))), dic2(arr(i, 3))) + 1
  25.         brr(dic1(Year(arr(i, 1)) & "/" & Month(arr(i, 1))), dic2(arr(i, 4))) = brr(dic1(Year(arr(i, 1)) & "/" & Month(arr(i, 1))), dic2(arr(i, 4))) + 1
  26.     Next
  27.     Sheets("出勤统计").Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
  28.     Set dic1 = Nothing
  29.     Set dic2 = Nothing
  30.     Erase arr
  31.     Erase brr
  32. End Sub
复制代码
  1. Sub 品牌拆分()
  2. '思路:采用下棋法,先定义两个字典,dic1装入所有型号,dic2 装手机品牌
  3.     Dim dic1 As New Dictionary, dic2 As New Dictionary
  4.     Dim arr, brr, crr, key1, key2, i As Long, j As Long, k As Long, T As Boolean
  5.     arr = Range("a1").CurrentRegion
  6.     brr = Range("g1").CurrentRegion
  7.     For i = 2 To UBound(arr)   '生成dic1字典
  8.         dic1(arr(i, 1)) = ""
  9.     Next
  10.     For i = 2 To UBound(brr)    '生成dic2字黄,顺便把贸易机和国产大牌所在的列数写入item
  11.         For j = 1 To 2
  12.             If brr(i, j) <> "" Then
  13.                 dic2(brr(i, j)) = j
  14.             End If
  15.         Next
  16.     Next
  17.     ReDim crr(1 To dic1.Count, 1 To 3)
  18.     i = 1
  19.     j = 1
  20.     k = 1
  21.     For Each key1 In dic1            '下棋
  22.         T = True
  23.         For Each key2 In dic2
  24.             If InStr(key1, key2) > 0 Then
  25.                 Select Case dic2(key2)
  26.                 Case Is = 1
  27.                     crr(i, dic2(key2)) = key1
  28.                     i = i + 1
  29.                     T = False
  30.                 Case Is = 2
  31.                     crr(j, dic2(key2)) = key1
  32.                     j = j + 1
  33.                     T = False
  34.                 End Select
  35.             End If
  36.         Next
  37.         If T Then
  38.             crr(k, 3) = key1
  39.             k = k + 1
  40.         End If
  41.     Next
  42.     [c2].Resize(UBound(crr), UBound(crr, 2)) = crr
  43. End Sub
复制代码

  1. Sub 平行志愿录取()
  2. '思路:定义两个数组arr和brr,分别把考生的数据和录取人数数据装入arr和brr
  3. '         采用下棋法,把学校代码装入字典,并把item对应brr 的行数
  4. '         把学生志愿拆分成装入学校代码的数组,对这数组进行循环,用dic(学校代码)找出在brr中的行数,然后比较计划人数 _
  5.         和实际人数,把相应的元素值改变,就得到最终数据了
  6.     Application.ScreenUpdating = False
  7.     Dim dic As Object, arr, brr, crr
  8.     Dim i As Long, L As Long, k As Long
  9.     Range("f2:f" & Range("a1").CurrentRegion.Rows.Count).ClearContents
  10.     Range("j2:k" & Range("h1").CurrentRegion.Rows.Count).ClearContents
  11.     arr = Range("a1").CurrentRegion
  12.     brr = Range("h1").CurrentRegion
  13.     Set dic = CreateObject("scripting.dictionary")
  14.     For i = 2 To UBound(brr)
  15.         dic(brr(i, 1)) = i
  16.     Next
  17.     For i = 2 To UBound(arr)
  18.         L = (Len(arr(i, 5)) - 1) / 2
  19.         If L > 0 Then
  20.             ReDim crr(1 To L)
  21.             For k = 1 To L
  22.                  crr(k) = "P" & Mid(Right(arr(i, 5), Len(arr(i, 5)) - 1), 2 * k - 1, 2)
  23.             Next
  24.             For k = 1 To UBound(crr)
  25.                 If dic.exists(crr(k)) Then
  26.                     If brr(dic(crr(k)), 2) > brr(dic(crr(k)), 3) Then
  27.                         brr(dic(crr(k)), 3) = brr(dic(crr(k)), 3) + 1
  28.                         arr(i, 6) = crr(k)
  29.                         brr(dic(crr(k)), 4) = arr(i, 4)
  30.                         Exit For
  31.                     End If
  32.                 End If
  33.             Next
  34.         End If
  35.     Next
  36.     For i = 2 To UBound(arr)
  37.         If IsEmpty(arr(i, 6)) Then
  38.             arr(i, 6) = "没有录取"
  39.         End If
  40.     Next
  41.     [a1].Resize(UBound(arr), UBound(arr, 2)) = arr
  42.     [h1].Resize(UBound(brr), UBound(brr, 2)) = brr
  43.     Application.ScreenUpdating = True
  44. End Sub
复制代码
回复 支持 反对

使用道具 举报

发表于 2017-9-5 23:08:20 | 显示全部楼层
  1. Option Explicit

  2. Sub 员工统计()
  3.     Dim arr, brr, i&, j&
  4.     Dim dit As New Dictionary, dic As New Dictionary
  5.     Sheets("员工出勤").Activate
  6.     arr = [a1].CurrentRegion
  7.     brr = WorksheetFunction.Transpose(Sheets("出勤统计").Range("c1:g1"))
  8.     For i = 1 To UBound(brr)
  9.         dit(brr(i, 1)) = i
  10.     Next
  11.     Erase brr
  12.     brr = Sheets("出勤统计").Range("a2:b15")
  13.     For i = 1 To UBound(brr)
  14.         dic(brr(i, 1) & "," & brr(i, 2)) = i
  15.     Next
  16.    
  17.     Erase brr
  18.     ReDim brr(1 To dic.Count, 1 To dit.Count)
  19.     For i = 3 To UBound(arr, 2)
  20.         For j = 2 To UBound(arr)
  21.             brr(dic(Year(arr(j, 1)) & "," & Month(arr(j, 1))), dit(arr(j, i))) = _
  22.             brr(dic(Year(arr(j, 1)) & "," & Month(arr(j, 1))), dit(arr(j, i))) + 1
  23.         Next
  24.     Next
  25.     Sheets("出勤统计").Range("c2").Resize(dic.Count, dit.Count) = brr
  26.     Erase arr, brr
  27.     Set dit = Nothing
  28.     Set dic = Nothing

  29. End Sub


  30. Sub 品牌拆分练习()
  31.     Dim arr, str, std, i&, j&, n&
  32.     Dim dit As New Dictionary, dic As New Dictionary
  33.     arr = [a1].CurrentRegion
  34.     For i = 2 To UBound(arr)
  35.         dit(arr(i, 1)) = ""
  36.     Next
  37.    
  38.     Erase arr
  39.     arr = [g1].CurrentRegion
  40.     For i = 1 To UBound(arr, 2)
  41.         For j = 2 To UBound(arr)
  42.             If arr(j, i) <> "" Then dic(arr(j, i)) = arr(1, i)
  43.         Next
  44.     Next
  45.    
  46.     Erase arr
  47.     i = 0
  48.     j = 0
  49.     ReDim arr(0 To dit.Count - 1, 1 To 3)
  50.     For Each std In dit
  51.         For Each str In dic
  52.             If std Like str & "*" And dic(str) = "贸易机" Then
  53.                 arr(i, 1) = std
  54.                 i = i + 1
  55.                 Exit For
  56.             ElseIf std Like str & "*" And dic(str) = "国产大牌" Then
  57.                 arr(j, 2) = std
  58.                 j = j + 1
  59.                 Exit For
  60.             End If
  61.         Next
  62.          
  63.         If str = "" Then
  64.             arr(n, 3) = std
  65.              n = n + 1
  66.         End If
  67.     Next
  68.    
  69.     Range("c2").Resize(dit.Count - 1, 3) = arr
  70.     Set dit = Nothing
  71.     Set dic = Nothing
  72.     Erase arr
  73.    
  74. End Sub


  75. Option Explicit
  76. Sub 成绩统计练习()
  77.     Application.ScreenUpdating = False
  78.     Dim arr, brr, crr, i&, j&, rng As Range, tt
  79.     tt = Timer
  80.     Dim dit As New Dictionary, dic As New Dictionary
  81.     Set rng = Union(Range("b3:n27"), Range("b31:n55"))
  82.     rng.ClearContents
  83.       
  84.     brr = Sheet1.[a1].CurrentRegion
  85.     crr = Sheet2.[a1].CurrentRegion
  86.     For i = 3 To UBound(brr)       '将总表导入数组后,利用循环进行简单的修改,使其符合下棋法要求
  87.         Select Case brr(i, 13)      '即分数出现分段标识和班级负责人分别写入原数组中用不到的数据区
  88.             Case Is >= 900
  89.                 brr(i, 14) = "900分以上"        '分数分段,可考虑了用数组循环做
  90.             Case Is >= 850
  91.                 brr(i, 14) = "850-900分"
  92.             Case Is >= 800
  93.                 brr(i, 14) = "800-850分"
  94.             Case Is >= 780
  95.                 brr(i, 14) = "780-800分"
  96.             Case Is >= 760
  97.                brr(i, 14) = "760-780分"
  98.             Case Is >= 740
  99.                 brr(i, 14) = "740-760分"
  100.             Case Is >= 720
  101.                 brr(i, 14) = "720-740分"
  102.             Case Is >= 700
  103.                 brr(i, 14) = "700-720分"
  104.             Case Is >= 680
  105.                 brr(i, 14) = "680-700分"
  106.             Case Is >= 660
  107.                 brr(i, 14) = "660-680分"
  108.             Case Is >= 640
  109.                 brr(i, 14) = "640-660分"
  110.             Case Is >= 620
  111.                 brr(i, 14) = "620-640分"
  112.             Case Is >= 600
  113.                 brr(i, 14) = "600-620分"
  114.             Case Is >= 580
  115.                 brr(i, 14) = "580-600分"
  116.             Case Is >= 560
  117.                 brr(i, 14) = "560-580分"
  118.             Case Is >= 540
  119.                 brr(i, 14) = "540-560分"
  120.             Case Is >= 520
  121.                brr(i, 14) = "520-540分"
  122.             Case Is >= 500
  123.                 brr(i, 14) = "500-520分"
  124.             Case Is >= 480
  125.                 brr(i, 14) = "480-500分"
  126.             Case Is >= 460
  127.                 brr(i, 14) = "460-480分"
  128.             Case Is >= 440
  129.                 brr(i, 14) = "440-460分"
  130.             Case Is >= 420
  131.                 brr(i, 14) = "420-440分"
  132.             Case Is >= 400
  133.                 brr(i, 14) = "400-420分"
  134.             Case Else
  135.                 brr(i, 14) = "400分以下"
  136.         End Select
  137.         For j = 3 To UBound(crr)
  138.             If brr(i, 4) Like crr(j, 1) & "*" Then
  139.                 brr(i, 15) = brr(i, 4) & " " & crr(j, 11)
  140.             End If
  141.         Next
  142.     Next
  143.    
  144.    
  145.     arr = Sheet3.[a1].CurrentRegion
  146.     For i = 3 To UBound(arr)        '用循环和字典将待用下棋法的横列字典分别列出。
  147.         dit(arr(i, 1)) = i - 2
  148.     Next
  149.     For i = 2 To UBound(arr, 2)
  150.         dic(arr(2, i)) = i - 1
  151.     Next
  152.     Erase arr
  153.    
  154.    
  155.     arr = Sheet3.[a2].Offset(1, 1).Resize(dit.Count, dic.Count)
  156.     For i = 3 To UBound(brr)                '下棋法填写该数据主区域
  157.         On Error Resume Next                '因为第一个表只是分数分段的一部分,需容错。
  158.         arr(dit(brr(i, 15)), dic(brr(i, 14))) = _
  159.         arr(dit(brr(i, 15)), dic(brr(i, 14))) + 1
  160.         On Error GoTo 0
  161.     Next
  162.     For i = 1 To UBound(arr, 2) - 1 '注意这里将最后一列留出
  163.         For j = 1 To 10
  164.             arr(UBound(arr) - 2, i) = arr(UBound(arr) - 2, i) + arr(j, i) '一组合计
  165.             arr(UBound(arr) - 1, i) = arr(UBound(arr) - 1, i) + arr(j + 10, i) '二组合计
  166.         Next
  167.         arr(UBound(arr), i) = arr(UBound(arr) - 3, i) + arr(UBound(arr) - 4, i) '国际部合计
  168.     Next
  169.     For i = 1 To UBound(arr)
  170.         For j = 1 To UBound(arr, 2) - 1                         '最后一列是前面数据列的累加值
  171.             arr(i, UBound(arr, 2)) = arr(i, UBound(arr, 2)) + arr(i, j)
  172.         Next
  173.     Next
  174.    
  175.     Sheet3.[a2].Offset(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr '数组值写入单元格区域
  176.    
  177.     Erase arr       '释放arr数组,注意此处不能提前释放brr,crr
  178. '    Set dit = Nothing   '清空字典,此字典本次可以不用清空
  179.     Set dic = Nothing
  180.    
  181.    
  182.     arr = Sheet3.[a30].CurrentRegion
  183. '    For i = 3 To UBound(arr)
  184. '        dit(arr(i, 1)) = i - 2
  185. '    Next
  186.     For i = 2 To UBound(arr, 2)
  187.         dic(arr(2, i)) = i - 1
  188.     Next
  189.     Erase arr
  190.         
  191.     '下面的代码基本复制前一部分代码,只是起始位置稍作修改。
  192.     arr = Sheet3.[a30].Offset(1, 1).Resize(dit.Count, dic.Count)
  193.     For i = 3 To UBound(brr)
  194.         On Error Resume Next
  195.         arr(dit(brr(i, 15)), dic(brr(i, 14))) = _
  196.         arr(dit(brr(i, 15)), dic(brr(i, 14))) + 1
  197.         On Error GoTo 0
  198.     Next
  199.     For i = 1 To UBound(arr, 2) - 1
  200.         For j = 1 To 10
  201.             arr(UBound(arr) - 2, i) = arr(UBound(arr) - 2, i) + arr(j, i)
  202.             arr(UBound(arr) - 1, i) = arr(UBound(arr) - 1, i) + arr(j + 10, i)
  203.         Next
  204.         arr(UBound(arr), i) = arr(UBound(arr) - 3, i) + arr(UBound(arr) - 4, i)
  205.     Next
  206.     For i = 1 To UBound(arr)
  207.         For j = 1 To UBound(arr, 2) - 1
  208.             arr(i, UBound(arr, 2)) = arr(i, UBound(arr, 2)) + arr(i, j)
  209.         Next
  210.     Next
  211.    
  212.     Sheet3.[a30].Offset(1, 1).Resize(UBound(arr), UBound(arr, 2)) = arr
  213.    
  214.     Erase arr, brr, crr
  215.     Set dit = Nothing
  216.     Set dic = Nothing
  217. '    MsgBox Format(Timer - tt, "0.000000")
  218. '    tt = Timer
  219.     Application.ScreenUpdating = True
  220.     MsgBox Format(Timer - tt, "0.000000")
  221. End Sub
复制代码


回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 入学

本版积分规则

关闭

站长推荐上一条 /2 下一条

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