Excel 2015VBA初级2班第4课A组作业上交贴（已开贴）

雪舞子 · 发表于 2015-11-12 13:17

本帖最后由雪舞子于 2015-11-15 16:58 编辑

作业说明及要求：

1、根据第四课所讲的内容，按老师布置的作业，编写一段自认为精练的代码；
2、提交作业请注明论坛ID及学号。如：A01-麻花_；
3、作业请以代码方式提交，标清题号并所有题贴到一个代码标签中，无需提交附件。不会使用标签可移步帖子：http://www.excelpx.com/thread-322284-1-1.html
4、代码题要求强制声明变量，关键语句标明注释，代码缩进;不会缩进可使用缩进小工具：http://www.excelpx.com/thread-366281-1-1.html
5、跟帖不要重复占楼,有问题直接在原帖编辑;
6、本次课程安排紧凑，时间紧任务重，同学们加油！
7、作业截止时间：第5课上课日之18:00时

guofei0344 · 发表于 2015-11-12 15:47

A02-guofei0344_
<div class="blockcode"><blockquote>

Sub 练习3()
Dim i As Integer, j As Integer, a As Integer
Dim arr, arr1, arr3(1 To 10, 1 To 8)
arr = Range("A1:A" & Range("a" & Range("a:a").Rows.Count).End(xlUp).Row)
arr1 = Range("A1:A" & Range("a1").End(xlDown).Row)
For i = 1 To UBound(arr1)
arr1(i, 1) = Left(arr1(i, 1), Application.Find("：", arr1(i, 1)) - 1)
Next
Range("C1").Resize(1, UBound(arr1)) = Application.Transpose(arr1)
For i = 1 To UBound(arr)
If arr(i, 1) <> "" Then
For j = 1 To UBound(arr1)
arr3(a + 1, j) = Mid(arr(i + j - 1, 1), Len(arr1(j, 1)) + 2, 30)
Next
a = a + 1
i = i + j
End If
Next
Range("C2").Resize(10, 8) = arr3
End Sub

复制代码

</blockquote></div><br />

Sub 表2()
Dim j As Integer, i As Integer
Dim arr, arr1(1 To 100)
On Error GoTo 100
arr = Range("c4:c" & Range("c" & Range("c:c").Rows.Count).End(xlUp).Row)
arr1(1) = Format(arr(1, 1), "yyyy年mm月")
For i = 1 To UBound(arr)
j = j + 1
If Format(arr(i, 1), "yyyymm") = Format(arr(i + 1, 1), "yyyymm") Then
arr1(j + 1) = arr(i, 1)
Else
arr1(j + 1) = arr(i, 1)
j = j + 1
arr1(j + 1) = Format(arr(i + 1, 1), "yyyy年mm月")
End If
Next
100:
arr1(j + 1) = arr(i, 1)
Sheets("表1").Range("m2").Resize(UBound(arr1), 1) = Application.Transpose(arr1)
End Sub

复制代码

jzkwf · 发表于 2015-11-12 21:42

A06:建峰
练习三：

Option Explicit
Option Base 1
'练习三
Sub 整理数据()
'第一步，定义变量，把数据装入数组
Dim lrows As Long, arr
lrows = Range("a1048576").End(xlUp).Row
arr = Range("a1:a" & lrows)
Range("c1:j1") = [{"财付通","佣金","QQ号码","旺旺小号","旺旺星级","下单金额","订单编号","QT编号"}]
'第二步，在数组中进行计算
Dim brr(1 To 1000000, 1 To 8) As Long, i As Byte, j As Long, x As Long
j = 1
x = 1
For lrows = 1 To UBound(arr)
If Left(arr(lrows, 1), 3) = "财付通" Then
For i = 0 To 7
brr(x, j + i) = --Right(arr(lrows + i, 1), Len(arr(lrows + i, 1)) - Application.WorksheetFunction.Find("：", arr(lrows + i, 1)))
Next
x = x + 1
lrows = lrows + i
End If
Next
'第三步，将数组中的数据写入单元格
Range("c2:j" & x) = brr
End Sub

复制代码

表1表2

Option Explicit
Option Base 1
Sub 添加月份()
'第一步，定义变量，把数据装入数组
Dim lrows As Long, arr
lrows = Range("c1048576").End(xlUp).Row
arr = Range("c4:c" & lrows)
'第二步，在数组中进行计算
Dim brr(1 To 1048576, 1 To 1), i As Long, j As Long
brr(1, 1) = Format(Year(arr(1, 1)) & "-" & Month(arr(1, 1)), "yyyy年m月")
brr(2, 1) = arr(1, 1)
j = 2
For i = 2 To UBound(arr)
If Month(arr(i, 1)) = Month(arr(i - 1, 1)) Then
j = j + 1
brr(j, 1) = arr(i, 1)
Else
j = j + 1
brr(j, 1) = Format(Year(arr(i, 1)) & "-" & Month(arr(i, 1)), "yyyy年m月")
j = j + 1
brr(j, 1) = arr(i, 1)
End If
Next
'第三步，将数组中的数据写入单元格
Sheets("表1").[m1] = "日期"
Sheets("表1").Range("m2:m" & j + 1) = brr
End Sub

复制代码

回答完毕！

开心妙妙 · 发表于 2015-11-13 10:39

Sub 练习3A() 'A03:开心妙妙
Dim Arr, iRow&, i&, j&, x&, n&
Application.ScreenUpdating = False
'区域赋值给数组
With Sheet4
iRow = .Range("A" & Rows.Count).End(xlUp).Row
Arr = .Range("A1:A" & iRow)
End With
'重置目标数组的大小,行数按原区域行除8,固定为8列大小
ReDim Brr(1 To iRow / 8 + 1, 1 To 8)
n = 1 '目标数值行初始变量
For i = 1 To iRow '原数据循环
If Arr(i, 1) <> "" Then '如果数据不为空,就+1
j = j + 1
x = InStr(1, Arr(i, 1), "：", 1) '查找":"在字符中的位置
If VBA.Left(Arr(i, 1), x - 1) = "财付通" Then
'如果前面的3个字符=财付通的时候,行+1,列从1开始
n = n + 1: j = 1
End If
If i < 9 Then
'判断原值行小于9的时候,即一条数据,第一行赋值标题,第二行赋值数据
Brr(1, j) = VBA.Left(Arr(i, 1), x - 1)
Brr(2, j) = VBA.Mid(Arr(i, 1), x + 1, 9)
Else
'否则 , 直接赋值数据
Brr(n, j) = VBA.Mid(Arr(i, 1), x + 1, 9)
End If
End If
Next
'二维数组,赋值给区域
Sheet4.Range("C1").Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
Application.ScreenUpdating = True
End Sub
Sub 练习3() 'A03:开心妙妙
Dim Arr, RowC&, ArrB, Brr(), i&, j&, j1&, n&
Application.ScreenUpdating = False
With Sheet4
RowC = .Range("A" & Rows.Count).End(xlUp).Row
Arr = .Range("A1:A" & RowC)
End With
n = 1
For i = 1 To RowC
If Arr(i, 1) <> "" Then
j = j + 1
j1 = j Mod 8 '求余数最得列号
ArrB = VBA.Split(Arr(i, 1), "：") '用Split分割成数据
If ArrB(0) = "财付通" Then
'判断如果数组的第一元素=财付通,行数+1,保留原值,重赋数组
'Preserve 只有最后一维可以用变量,所以将行置成列,将列置成行
n = n + 1
ReDim Preserve Brr(1 To 8, 1 To n)
End If
'求余数8的时候,余数是0,要作个判断,余数是0的时候=8
If j1 = 0 Then j1 = 8
If j < 9 Then
'判断如果行小于9的时候,拆分的第一个元素赋值给第一行,第二个元素赋值给第二行
Brr(j1, 1) = ArrB(0)
Brr(j1, n) = ArrB(1)
Else
'否则,直接赋值
Brr(j1, n) = ArrB(1)
End If
End If
Next
Sheet4.Range("C1").Resize(UBound(Brr, 2), UBound(Brr, 1)) = Application.WorksheetFunction.Transpose(Brr)
Application.ScreenUpdating = True
End Sub
Sub 日期格式整理()
Dim Arr, i&, Brr(1 To 10000), n&
Application.ScreenUpdating = False
With Sheet13 ''数据存入数组
Arr = .Range("C4:C" & .Range("C" & Rows.Count).End(xlUp).Row)
End With
Brr(1) = VBA.Format(Arr(1, 1), "YYYY年M月") ' '数组的第一个值设置好格式后存入
n = 1 '第一个值己赋入,初始变量为1
For i = 1 To UBound(Arr)
n = n + 1 '按原值循环加1
If i >= UBound(Arr) Then
'判断I>=数组最大个数,这里避免在循环到最后一个值的时候,无法和下一个的月份对比而出错.
Brr(n) = Arr(i, 1)
Else
If VBA.Month(Arr(i, 1)) <> VBA.Month(Arr(i + 1, 1)) Then
'如果月份不想等的时候,先赋值,然后N+1,再赋下一月份的值
Brr(n) = Arr(i, 1)
n = n + 1
Brr(n) = VBA.Format(Arr(i + 1, 1), "YYYY年M月")
Else '否则,直接赋值
Brr(n) = Arr(i, 1)
End If
End If
Next
'生成的一维数组,赋值给区域前转置
Sheet12.Range("M2").Resize(n) = Application.WorksheetFunction.Transpose(Brr)
Application.ScreenUpdating = True
End Sub

复制代码

神隐汀渚 · 发表于 2015-11-13 10:49

1、

Sub 日期变月份()
Dim arr(), i As Integer, irows As Integer
irows = Range("c4").End(xlDown).Row
arr() = Range("c4:c" & irows)
ReDim Preserve arr(1 To irows - 3, 1 To 1)
Dim brr(1 To 65535, 1 To 1)
For i = 1 To UBound(arr())
brr(i, 1) = Format(arr(i, 1), "yyyy年m月")
'MsgBox brr(i, 1)
Next i
Sheets("表1").Range("m2：m" & irows) = brr
End Sub

复制代码

2、

Sub 数据处理()
Dim i As Long, arr(), brr(), t As Single
t = Timer
i = Range("a" & 1048576).End(xlUp).Row 'i等于最后行号
arr = Range("a1:a" & i) 'arr 等于a1到最后一个
brr = Range("c1：j1") 'brr 等于c1：j1
ReDim Preserve arr(1 To i, 1 To 1) '重新定义 arr的范围但保留原来赋值
Dim j As Long, crr As String, k As Integer '定义 j，k 整型变量 crr为文本型
For k = 1 To 8 'k范围从1到8
If k > 1 Then '如果k大于1 那么清除crr
crr = ""
End If
For j = 1 To i ' j范围从1到 i
If Left(arr(j, 1), Len(brr(1, k))) = brr(1, k) Then '如果冒号前面的文字等于数组brr 那么
crr = crr & Right(arr(j, 1), Len(arr(j, 1)) - Len(brr(1, k))) 'crr就等于arr后半段相连
End If
Next j
Dim l As String, m As Long, drr '定义l为文本 m 为长整型 drr为变体型
l = Right(crr, Len(crr) - 1) 'l =去掉crr 第一个字符
drr = Split(l, "：") '根据冒号将 l分解成1维数组
'ReDim drr(2 * k - 2 To UBound(drr) - 2 + 2 * k, 1 To 1)
Range(Chr(k + 66) & "2:" & Chr(k + 66) & UBound(drr) + 2) = Application.Transpose(drr) '给2：4行赋值
'MsgBox Chr(k + 66)
'Set crr = Clear
'crr.Select.ClearContents
Next k '下一个k
MsgBox Format(Timer - t, "0.0000s")
End Sub

复制代码

ZL在水一方 · 发表于 2015-11-13 11:44

A12-ZL在水一方

先交一题，另一题还没搞定

Option Explicit
Sub 数据整理()
Dim arr As Variant, j As Long, i As Long, MaxRow As Long, iRows As Long, brr(), t As Single
't = Timer
'******整理数据源，删除空行******
MaxRow = Cells(Rows.Count, 1).End(xlUp).Row
Application.ScreenUpdating = False
For j = MaxRow To 1 Step -1
If Cells(j, 1) = "" Then
Rows(j).EntireRow.Delete
End If
Next
'******将单元格数据放入数组******
iRows = Cells(Rows.Count, 1).End(xlUp).Row
arr = Range("a1:a" & iRows)
'******数组内执行语句******
ReDim brr(1 To UBound(arr) / 8, 1 To 8)
For i = 1 To UBound(arr)
brr(Int((i - 1) / 8) + 1, IIf(i Mod 8 = 0, 8, i Mod 8)) = Mid(arr(i, 1), InStr(arr(i, 1), "：") + 1, 99)
Next i
'******将数组返回至单元格******
[c:j].ClearContents
[c1].Resize(1, 8) = Array("财付通", "佣金", "QQ号码", "旺旺小号", "旺旺星级", "下单金额", "订单编号", "QT编号")
[c2].Resize(UBound(arr) / 8, 8) = brr
Application.ScreenUpdating = True
'MsgBox Format(Timer - t, "0.0000")
End Sub

复制代码

denil · 发表于 2015-11-13 17:26

Sub 练习三()
'步骤1
Dim arr, irows As Long
irows = Range("a1").End(xlDown).Row
arr = Range("A1:a" & irows)
'步骤2
Dim brr(1 To 8, 1 To 1), i As Integer, crr(1 To 10, 1 To 1)
For i = 1 To irows
brr(i, 1) = Split(arr(i, 1), "：")(0)
crr(i, 1) = Split(arr(i, 1), "：")(1)
Next i
'步骤3
Range("c1").Resize(1, irows) = Application.Transpose(brr)
Range("c2").Resize(1, irows) = Application.Transpose(crr)
End Sub
..只会做一组数据的。。其他没想到怎么做。。

复制代码

麻花_ · 发表于 2015-11-13 18:47

姓名：A01-麻花_

第一题：

不会

复制代码

第二题：

还是不会

复制代码

第三题：

真的还是不会...

复制代码

弄了好久，总感觉卡在什么地方出不来。先占一个楼，等开贴后参考其他学员作业看看。
不管是函数，还是VBA，每每老师讲到数组的时候，那感觉就像失恋一样，无法逾越。

雪舞子 · 发表于 2015-11-15 16:36

本帖最后由雪舞子于 2015-11-15 17:13 编辑

此次作业很多同学的代码写的都非常棒，思路新颖，代码简洁，

以下是仅是我的思路供大家参考，错误之处欢迎大家指正：

Sub 作业一() '利用split() 函数分列出"："前后的数据
Dim arr, brr(), i&, z&, j%, n% 'arr源数据，brr结果数据，z计数结果数组，n计数每组8行数据
arr = Range("a1:a" & [a65536].End(3).Row) 'A列数据赋值给数组
ReDim brr(UBound(arr) / 8, 1 To 8) '重新定义结果数组，由于源数据是8条数据一组，结果数组不会超过源数组行数除8。结果数组0行给表头保留。
For i = 1 To 8
brr(0, i) = Split(arr(i, 1), "：")(0) '表头写进结果数组（brr）0行
Next
z = 1 '结果数据行数从1行开始
For i = 1 To UBound(arr) '循环源数据行数1~最后一行
If Cells(i, 1) <> "" Then '如果源某条数据不为空，从这条数据开始计数8行（8行一组）
n = n + 1 '计数
brr(z, n) = Split(arr(i, 1), "：")(1) 'z为结果数组行数，n计数源数据，计到8行为止，n同时也是结果数据的列数（共8列）
If n > 7 Then n = 0: z = z + 1 '上面结果数组写满了8列（源数据也走了8行），即这里n>7，重置n为0，结果数组行数z+1
End If
Next
[c20].Resize(z, 8) = brr
End Sub
Sub 作业二()
Dim arr, brr(), i%, n%
arr = Range("c3:c" & [c65536].End(3).Row) 'C列数据赋值给数组
ReDim brr(1 To UBound(arr) + 12, 1 To 1) '目测一下源数据没有超过12个月，结果数据最多也就是源数据+12
For i = 2 To UBound(arr) '循环源数据2行开始到结尾
If Format(arr(i - 1, 1), "m") <> Format(arr(i, 1), "m") Then '比较上一行与本行月份是否一致，不一致插入1行"yyyy年m月"
n = n + 1 '行+1
brr(n, 1) = Format(arr(i, 1), "yyyy年m月") '插入1行"yyyy年m月"
End If
n = n + 1 '计数结果数组行数，行数+1
brr(n, 1) = arr(i, 1) '源数据写入结果数组
Next
[m2].Resize(n) = brr
End Sub

复制代码

雪舞子 · 发表于 2015-11-15 16:37

作业截止---------------------------------------------------------------------------------------------------------------

		自动登录	找回密码
密码			注册

[通知] Excel 2015VBA初级2班第4课A组作业上交贴（已开贴）

评分

相关帖子

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分

评分