Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2878|回复: 7

[习题] 【已开贴】Excel 2015VBA初级2班第4课B组作业上交贴

[复制链接]
发表于 2015-11-12 16:03 | 显示全部楼层 |阅读模式
本帖最后由 wp8680 于 2015-11-14 12:20 编辑

学习的进度太快了,交贴都跟不上快了。

作业说明及要求:

1、根据第四课所讲的内容,按课堂中的布置的作业,编写一段自认为精练的代码。
2、纯录制代码不加分!无独特思考内容的代码不加分!抄袭他人代码无新意不加分!粗糙不合理的代码少加分!
3、提交作业请注明论坛ID及学号。如:B01-***;作业可以压缩包方式提交,也可以直接贴代码;
4、代码题要求强制声明变量,代码缩进
5、学习是自愿的,学成也是自已的。
6、我们的目标:超出自我,胜出自我。
7、作业截止时间:尽量早点吧,练习是最后的实践。
发表于 2015-11-12 17:25 | 显示全部楼层
太难,只能占个楼梯!

点评

赶紧写代码交作业吧,按论坛以住规定,作业贴不交作业而随便跟贴的,是要被扣分的。!!!  发表于 2015-11-13 07:44
回复

使用道具 举报

发表于 2015-11-12 19:34 | 显示全部楼层
本帖最后由 lvxia 于 2015-11-12 19:37 编辑

B10:lvxia
  1. Option Explicit
  2. Sub 不规范数据转清单()
  3.     Dim arr1, arr2, brr, crr, drr
  4.     Dim irows As Long, i As Long, j As Long, k As Byte, Icolumns1 As Byte, Icolumns2 As Byte
  5.     irows = Range("a65536").End(xlUp).Row
  6.     arr1 = Range("a1:a" & irows)
  7.     '求brr列数
  8.     For i = 1 To UBound(arr1)
  9.         If arr1(i, 1) <> "" Then
  10.             Icolumns1 = Icolumns1 + 1
  11.         Else
  12.             Exit For
  13.         End If
  14.     Next
  15.     '求arr2行数
  16.         For i = 1 To UBound(arr1)
  17.         If arr1(i, 1) <> "" Then Icolumns2 = Icolumns2 + 1
  18.     Next
  19.     '非空数据存入arr2
  20.     ReDim arr2(1 To Icolumns2, 1 To 1)
  21.     For i = 1 To UBound(arr1)
  22.         If arr1(i, 1) <> "" Then j = j + 1: arr2(j, 1) = arr1(i, 1)
  23.    Next
  24.    'arr2分列,存入brr
  25.    ReDim brr(1 To Icolumns2, 1 To 2)
  26.    For i = 1 To UBound(arr2)
  27.         drr = Split(arr2(i, 1), ":")
  28.         brr(i, 1) = drr(0)
  29.         brr(i, 2) = drr(1)
  30.    Next
  31.   '转置后存入crr
  32.     ReDim crr(1 To Icolumns2 / Icolumns1 + 1, 1 To Icolumns1)
  33.     For i = 1 To Icolumns1
  34.         crr(1, i) = brr(i, 1)
  35.     Next
  36.     j = 1
  37.     For i = 2 To Icolumns2 / Icolumns1 + 1
  38.         For k = 1 To Icolumns1
  39.             If brr(j, 1) = crr(1, k) Then crr(i, k) = brr(j, 2): j = j + 1
  40.         Next
  41.     Next
  42.     '结果写入指定区域
  43.     [c1].Resize(UBound(crr), UBound(crr, 2)) = crr
  44. End Sub
复制代码
  1. Option Explicit
  2. Sub 日期()
  3.     Dim arr1, arr2, arr3, irows%, ICount%, i%, j%, k%, m%
  4.    irows = Worksheets("表2").Range("C4").End(xlDown).Row
  5.    arr1 = Worksheets("表2").Range("C4:C" & irows)
  6.     k = 1
  7.    ReDim arr2(1 To UBound(arr1), 1 To 1)
  8.    For i = 1 To UBound(arr1)
  9.         For j = 1 To UBound(arr1)
  10.             If Year(arr2(j, 1)) & Month(arr2(j, 1)) = Year(arr1(i, 1)) & Month(arr1(i, 1)) Then ICount = ICount + 1
  11.         Next
  12.         If ICount = 0 Then
  13.             arr2(k, 1) = arr1(i, 1)
  14.             k = k + 1
  15.         Else
  16.             ICount = 0
  17.         End If
  18.    Next
  19.    '求出arr2非空元素的个数
  20.    For i = 1 To UBound(arr2)
  21.         If arr2(i, 1) <> "" Then ICount = ICount + 1
  22.    Next
  23.    k = 1
  24.    m = 1
  25. '结果数据存入arr3
  26.    ReDim arr3(1 To UBound(arr1) + ICount, 1 To 1)
  27.    For i = 1 To ICount
  28.         arr3(k, 1) = Year(arr2(i, 1)) & "年" & Month(arr2(i, 1)) & "月"
  29.         For j = m To UBound(arr1)
  30.             If Year(arr1(j, 1)) & Month(arr1(j, 1)) = Year(arr2(i, 1)) & Month(arr2(i, 1)) Then
  31.                 k = k + 1
  32.                 arr3(k, 1) = arr1(j, 1)
  33.             Else
  34.                 k = k
  35.                 Exit For
  36.             End If
  37.         Next
  38.         k = k + 1
  39.        m = j
  40.    Next
  41.    '结果写入表一指定区域
  42.    Worksheets("表1").Range("M2").Resize(UBound(arr3)) = arr3
  43. End Sub
复制代码

点评

代码是正确的,但其中的方法个人以为还可以改进。只要逻辑关系正确,采用什么方法也就不重要了。  发表于 2015-11-13 07:59

评分

参与人数 1 +16 金币 +16 收起 理由
wp8680 + 16 + 16 很给力!

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-11-13 14:44 | 显示全部楼层
  1. Sub 转()
  2.     Dim arr, i%, n%, k%, brr()
  3.     arr = Range("a1:a" & Range("a" & Cells.Rows.Count).End(xlUp).Row)
  4.     ReDim brr(1 To 9999, 1 To 8)
  5.     Do
  6.         i = i + 1
  7.         If arr(i, 1) <> "" Then
  8.             k = k + 1
  9.             Do While arr(i + n, 1) <> ""
  10.                 brr(k, n + 1) = Split(arr(i + n, 1), ":")(1)
  11.                 n = n + 1
  12.                 If i + n > UBound(arr, 1) Then Exit Do
  13.             Loop
  14.         End If
  15.         i = i + n
  16.         n = 0
  17.     Loop While i < UBound(arr, 1)
  18.     Range("c2").Resize(k, 8) = brr
  19. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2015-11-13 15:08 | 显示全部楼层
  1. Sub 日期2()
  2.     Dim arr, brr(), i%, k%, m$
  3.     arr = Worksheets("表2").Range("C4:C" & Worksheets("表2").Range("C4").End(xlDown).Row)
  4.     For i = 1 To UBound(arr, 1)
  5.         If m <> Format(arr(i, 1), "yyyy年M月份") Then
  6.             m = Format(arr(i, 1), "yyyy年M月份")
  7.             k = k + 1
  8.             ReDim Preserve brr(1 To k)
  9.             brr(k) = m
  10.         End If
  11.         k = k + 1
  12.         ReDim Preserve brr(1 To k)
  13.         brr(k) = arr(i, 1)
  14.     Next
  15.     '结果写入表一指定区域
  16.     Worksheets("表1").Range("m2").Resize(k, 1) = Application.WorksheetFunction.Transpose(brr)
  17. End Sub
复制代码
回复

使用道具 举报

发表于 2015-11-13 15:12 | 显示全部楼层
  1. Option Explicit

  2. Sub 作业1整理格式()
  3. Dim i As Integer, regx, mat, rng, m, j As Integer
  4. j = 1
  5. Set regx = CreateObject("vbscript.regexp") '绑定正则表达式
  6. With regx
  7.     .Global = True '全部查找
  8.     .Pattern = "\d+" '匹配数字字符
  9.     For Each rng In Range("a1:a" & Range("a35546").End(xlUp).Row)
  10.         Set mat = .Execute(rng) '返回匹配成功的结果,是一个对象。
  11.         For Each m In mat
  12.             i = i + 1
  13.             If i > 8 Then j = j + 1: i = 1
  14.             [b1].Offset(j, i) = m
  15.         Next
  16.     Next
  17. End With
  18. End Sub
复制代码

评分

参与人数 1 +8 金币 +8 收起 理由
wp8680 + 8 + 8 只做了一个,少评一点啰。

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2015-11-13 15:51 | 显示全部楼层
  1. Sub 日期2()
  2.     Dim arr, brr(), i%, k%, m$
  3.     arr = Worksheets("表2").Range("C4:C" & Worksheets("表2").Range("C4").End(xlDown).Row)
  4.     ReDim brr(1 To 9999, 1 To 1)
  5.     For i = 1 To UBound(arr, 1)
  6.         If m <> Format(arr(i, 1), "yyyy年M月份") Then
  7.             m = Format(arr(i, 1), "yyyy年M月份")
  8.             k = k + 1
  9.             brr(k, 1) = m
  10.         End If
  11.         k = k + 1
  12.         brr(k, 1) = arr(i, 1)
  13.     Next
  14.     Worksheets("表1").Range("m2").Resize(k, 1) = brr
  15. End Sub
复制代码
回复

使用道具 举报

发表于 2015-11-13 19:40 | 显示全部楼层
B11:hsl215
作业一
  1. Sub ex1()
  2.     Application.ScreenUpdating = False
  3.     Dim i&, k&, x&, y&, arr, dic
  4.     Set dic = CreateObject("scripting.dictionary")
  5.     arr = Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
  6.     k = UBound(arr)
  7.     For i = 1 To k
  8.         If arr(i, 1) <> "" Then
  9.             dic(Mid(arr(i, 1), 1, InStr(arr(i, 1), ":") - 1)) = ""
  10.         End If
  11.     Next
  12.     Range("L:L").Resize(, dic.Count).ClearContents
  13.     Range("L1").Resize(, dic.Count) = dic.keys
  14.         For x = 1 To k
  15.         For y = 12 To 11 + dic.Count
  16.             If arr(x, 1) <> "" Then
  17.                 If Mid(arr(x, 1), 1, InStr(arr(x, 1), ":") - 1) = Cells(1, y) Then
  18.                     Cells(1, y).Offset(Cells(Rows.Count, y).End(xlUp).Row, 0) = Mid(arr(x, 1), InStr(arr(x, 1), ":") + 1, 9)
  19.                 End If
  20.             End If
  21.         Next
  22.     Next
  23.     Application.ScreenUpdating = True
  24. End Sub
复制代码
作业二还有点问题没有解决,先交了再修改了
  1. Sub 作业2()
  2.     Dim i%, j%, arr, brr
  3.     Sheets("表2").Select
  4.     arr = Range("C3:C" & Range("C" & Rows.Count).End(xlUp).Row)
  5.     ReDim brr(0 To UBound(arr) + 12)
  6.     For i = 1 To UBound(arr)
  7.         If IsDate(arr(i, 1)) Then
  8.             If IsDate(arr(i - 1, 1)) And Format(arr(i - 1, 1), "yyyy年m月") <> Format(arr(i, 1), "yyyy年m月") Then
  9.                 brr(j) = Format(arr(i, 1), "yyyy年m月")
  10.                 brr(j + 1) = arr(i, 1)
  11.                 j = j + 1
  12.             Else
  13.                 brr(j) = arr(i, 1)
  14.             End If
  15.         Else
  16.             brr(j) = Format(arr(i + 1, 1), "yyyy年m月")
  17.         End If
  18.         j = j + 1
  19.     Next
  20.     Stop
  21.     Sheets("表1").Select
  22. '    Sheets("表1").Range("o2:ac39") = WorksheetFunction.Transpose(brr)
  23. '    Range("o2:p39") = brr
  24.     Range("l2").Resize(UBound(brr), 2) = brr
  25. End Sub
复制代码

点评

第一个作业,建议写成数组一次性写入表格,提高运算速度。  发表于 2015-11-14 10:18
在第9行与第10中间加一句j=j+1,然后把第brr(j+1)=arr(i,1)改为brr(j)=arr(i,1)  发表于 2015-11-14 10:17

评分

参与人数 1 +8 金币 +8 收起 理由
wp8680 + 8 + 8 ok

查看全部评分

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-3-29 22:58 , Processed in 1.379810 second(s), 9 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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