6月5/6日 Excel函数实战技巧精粹 300集Office 2010微视频教程
5月7日 Excel VBA开发实战 高效办公必会的Office实战技巧
5月6日 Excel透视表实战秘技 网易云课堂-Excel数据透视表应用大全
Excel数据处理与分析实战技巧第1季
查看: 111|回复: 4

VBA实战开发第五期-第二课作业贴

[复制链接]
发表于 2018-5-14 12:07:37 | 显示全部楼层 |阅读模式



VBA实战开发第五期-第二课作业贴







回复

使用道具 举报

发表于 2018-5-14 15:16:26 | 显示全部楼层
第二课作业.数组排序

  1. '算法入门:选择排序
  2. Sub Homework_SelectionSort()
  3.     Dim arr(1 To 10) As Long, i As Long, j As Long, min As Long, 次 As Long
  4.    
  5.     For i = 1 To 10
  6.         arr(i) = WorksheetFunction.RandBetween(1, 50)

  7.     Next
  8.     '从小到大排序
  9. '
  10.     For j = 1 To 10
  11.         If j = 10 Then Exit For
  12.         
  13.         For i = j To 10
  14.             If i = j Then
  15.                 min = arr(i)
  16.                 次 = i
  17.             End If
  18.             If min > arr(i) Then
  19.                 min = arr(i)
  20.                 次 = i
  21.              End If
  22.             
  23.         Next
  24.         If 次 = j Then
  25.             arr(j) = arr(次)
  26.         Else
  27.             arr(次) = arr(j)
  28.             arr(j) = min
  29.         End If
  30.     Next
  31. End Sub

复制代码
回复 支持 反对

使用道具 举报

发表于 2018-5-14 15:18:04 | 显示全部楼层
第二课作业

数组基础练习3小题

  1. Sub 转置练习()
  2.     Dim arr()
  3.         arr = Range("a1").CurrentRegion
  4.         arr = WorksheetFunction.Transpose(arr)
  5.         Range("d1").Resize(UBound(arr), UBound(arr, 2)) = arr

  6. End Sub

  7. Sub 重排练习()
  8.     Dim arr(), brr()
  9.     Dim rng As Range, lr As Long, i As Long, k As Long
  10.     lr = Range("a" & Rows.Count).End(xlUp).Row
  11.     Set rng = Range([a1], Cells(lr + 1, 1))
  12.     arr = rng
  13.     For i = 1 To UBound(arr) - 1
  14.         If arr(i, 1) <> "" And arr(i + 1, 1) = "" Then
  15.             k = k + 1
  16.             brr = Range("a" & i - 1).CurrentRegion
  17.             Cells(6, k + 2).Resize(UBound(brr), 1) = brr
  18.         End If
  19.     Next
  20. End Sub

  21. Sub 动态练习()
  22.     Dim arr()
  23.     Dim i As Long, k As Long
  24.    
  25.     arr = Range("a1").CurrentRegion
  26.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  27.     For i = 1 To UBound(arr)
  28.         If arr(i, 2) > 89 Then
  29.             k = k + 1
  30.             brr(k, 1) = arr(i, 1)
  31.             brr(k, 2) = arr(i, 2)
  32.             
  33.         End If
  34.     Next
  35.     Range("i6") = k - 1
  36.     Range("d8").Resize(UBound(brr), UBound(brr, 2)) = brr
  37. End Sub

复制代码
回复 支持 反对

使用道具 举报

发表于 2018-5-14 15:20:50 | 显示全部楼层
数组  连续
  1. Sub 加班超7天作业()
  2.     Dim arr
  3.     Dim i As Long, j As Long, k As Long, max As Long
  4.    
  5.     arr = Range("a1").CurrentRegion
  6.         For i = 6 To UBound(arr)
  7.             max = 7
  8.             k = 0
  9.             For j = 2 To UBound(arr, 2)
  10.                 If arr(i, j) <> "02" And arr(i, j) <> "" And arr(i, j) <> "*" Then
  11.                     k = k + 1
  12.                     If k > max Then
  13.                         max = k
  14.                         Cells(i, 33) = max
  15.                     End If
  16.                 Else
  17.                     k = 0
  18.                 End If
  19.             Next
  20.         Next
  21. End Sub
复制代码
加班超过7天的人

回复 支持 反对

使用道具 举报

发表于 2018-5-18 14:39:31 | 显示全部楼层
  1. Sub Arrtranspost()
  2.     Range("a15:g16").ClearContents
  3.     Dim arr
  4.     arr = Range("a1:b7")
  5.     arr = WorksheetFunction.Transpose(arr)
  6.     [a15].Resize(2, UBound(arr, 2)) = arr
  7. End Sub
  8. Sub ChongPai()
  9.     Range("c6:N20").ClearContents
  10.     Dim arr(), drr(1 To 15, 1 To 12)
  11.     Dim i As Long, j As Long, k As Long
  12.     arr = Range("a1:a42")
  13.     arr = WorksheetFunction.Transpose(arr)
  14.     j = 1
  15.     k = 1
  16.     For i = 1 To UBound(arr)
  17.         If arr(i) <> "" Then
  18.            drr(j, k) = arr(i)
  19.             j = j + 1
  20.         Else
  21.             If arr(i + 1) <> "" Then
  22.                 j = 1
  23.                 k = k + 1
  24.                 End If
  25.         End If
  26.     Next
  27.     [c6].Resize(15, 12) = drr
  28. End Sub

  29. Sub search()
  30.     Range("d8:e80").ClearContents
  31.     Dim arr(), brr()
  32.     Dim i As Long, j As Long
  33.     arr = Range("a1").CurrentRegion.Value
  34.     j = 1
  35.     ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
  36.     For i = 2 To UBound(arr)
  37.         If arr(i, 2) > 89 Then
  38.             brr(j, 1) = arr(i, 1)
  39.             brr(j, 2) = arr(i, 2)
  40.             j = j + 1
  41.         End If
  42.     Next
  43.     [d8].Resize(UBound(arr), 2) = brr
  44. End Sub
复制代码
回复 支持 反对

使用道具 举报

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

本版积分规则

关闭

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

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