梅一枝
发表于 2012-4-25 23:05
:'$在老师的带领下，又温习一次DO语句。
Iweb002
发表于 2012-4-26 08:15
坚持学习，总有收获。
君子豹变
发表于 2012-4-26 13:45
老师，上一课作业我不会做，听完课后才做。现交如下
Sub 第一题_按钮2_单击()
Dim rg1, rg2 As Range
Dim firstRow, endRow, k As Integer
Set rg1 = Range("a1")
Do
k = k + 1
Set rg1 = Range("a:a").Find("A", after:=rg1, lookat:=xlWhole)
firstRow = rg1.Row
Set rg2 = Range("a:a").Find("A", after:=rg1, lookat:=xlWhole)
If rg2.Row < firstRow Then
endRow = Range("a65536").End(xlUp).Row
Else
endRow = rg2.Row - 1
End If
Range("a" & firstRow & ":a" & endRow).Copy Cells(1, 2 + k)
Loop Until rg2.Row < firstRow
End Sub
Sub 按钮2_单击()
Dim x, firstRow As Integer
If IsNull(Range("a1:a15").MergeCells) = True Then
Range("a1:a15").UnMerge
Else
For x = 2 To Range("a65536").End(xlUp).Row
firstRow = x
Do
x = x + 1
Loop Until Cells(x, 1) <> Cells(x + 1, 1)
Range(Cells(firstRow, 1), Cells(x, 1)).Merge
Application.DisplayAlerts = False
Next x
End If
End Sub
第二题还有个疑问，如果合并之后，只剩下左上角数据了，中间会空一些，怎么办呢？
我加了一个判断，如下
Sub 按钮2_单击()
Dim x, firstRow As Integer
If IsNull(Range("a1:a15").MergeCells) = True Then
Range("a1:a15").UnMerge
For x = 2 To 15
If Cells(x, 1) = "" Then Cells(x, 1) = Cells(x - 1, 1)
Next x
Else
For x = 2 To Range("a65536").End(xlUp).Row
firstRow = x
Do
x = x + 1
Loop Until Cells(x, 1) <> Cells(x + 1, 1)
Range(Cells(firstRow, 1), Cells(x, 1)).Merge
Application.DisplayAlerts = False
Next x
End If
End Sub
本节课数组的作业
Sub 填充()
Dim arr
Dim arr1(1 To 10000, 1 To 1)
Dim i, j, m As Integer
arr = Range("a1:d17")
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If arr(i, j) < 0 Then
m = m + 1
arr1(m, 1) = arr(i, j)
Cells(m, "M") = arr1(m, 1)
arr(i, j) = 0
End If
Next j
Next i
Range("g1:j17") = arr
Erase arr
Erase arr1
End Sub
Sub 清空()
Range("g1:j17") = ""
Range("m:m") = ""
End Sub
想飞的鸟
发表于 2012-4-27 14:11
Sub 按钮2_单击()
Dim X As Integer, 开始行数 As Integer
If IsNull(Range("a1:a15").MergeCells) = True Then
Range("a1:a15").UnMerge
Else
For X = 2 To Range("a65536").End(xlUp).Row
开始行数 = X
Do
X = X + 1
Loop Until Cells(X + 1, 1) <> Cells(X, 1)
Application.DisplayAlerts = False
Range(Cells(开始行数, 1), Cells(X, 1)).Merge
Application.DisplayAlerts = True
Next X
End If
End Sub
Sub 第一题_按钮2_单击()
Dim X As Integer, 开始行数, 结束行数
Dim rg As Range, rg1 As Range, y As Integer, k As Integer
Set rg = Range("a1")
Do
k = k + 1
Set rg = Range("a:a").Find("A", after:=rg, lookat:=xlWhole)
开始行数 = rg.Row
Set rg1 = Range("a:a").Find("A", after:=rg, lookat:=xlWhole)
If rg1.Row < 开始行数 Then
结束行数 = Range("A65536").End(xlUp).Row
Else
结束行数 = rg1.Row - 1
End If
Range(Cells(开始行数, 1), Cells(结束行数, 1)).Copy Cells(k + 2)
Loop Until rg1.Row < 开始行数
End Sub
liuho1
发表于 2012-4-27 15:27
不好意思，上次可没来听，作业没及时完成，补交
libenwen2011
发表于 2012-4-28 17:33
Sub 第13课数组作业()
Dim x As Long, y As Long, h
Dim arr(1 To 17, 1 To 4)
h = 0
For x = 1 To 17
For y = 1 To 4
arr(x, y) = Cells(x, y)
Cells(x, y + 6) = arr(x, y) '要求1
If arr(x, y) < 0 Then
Cells(x, y + 6) = 0
End If
If arr(x, y) < 0 Then '要求2： 把负数全部显示到M列
h = h + 1
Range("m" & h) = arr(x, y)
End If
Next y
Next x
End Sub
libenwen2011
发表于 2012-4-28 17:46
老师你好，对不起，搞忘了写论坛ID号，现在补上，我的新组编号没有找到，27楼是我的作业
libenwen2011 (UID: 514207)
一直都在忙，今天才能抽空完成作业
谢谢老师体谅！！
libenwen2011
发表于 2012-4-28 18:57
对不起，搞错了，第16周的作业
gaoshuichang1
发表于 2012-4-29 21:15
Sub 第一题_按钮2_单击()
Dim x As Integer, 开始行数, 结束行数
Dim rg As Range, rg1 As Range, y As Integer, k As Integer
Set rg = Range("a1")
Do
k = k + 1
Set rg = Range("a:a").Find("A", after:=rg, lookat:=xlWhole)
开始行数 = rg.Row
Set rg1 = Range("a:a").Find("A", after:=rg, lookat:=xlWhole)
If rg1.Row < 开始行数 Then
结束行数 = Range("A65536").End(xlUp).Row
Else
结束行数 = rg1.Row - 1
End If
Range(Cells(开始行数, 1), Cells(结束行数, 1)).Copy Cells(1, k + 2)
Loop Until rg1.Row < 开始行数
End Sub
Sub 按钮2_单击()
Dim x As Integer, 开始行数 As Integer
If IsNull(Range("a1:a15").MergeCells) = True Then
Range("a1:a15").UnMerge
Else
For x = 2 To Range("a65536").End(xlUp).Row
开始行数 = x
Do
x = x + 1
Loop Until Cells(x + 1, 1) <> Cells(x, 1)
Application.DisplayAlerts = False
Range(Cells(开始行数, 1), Cells(x, 1)).Merge
Application.DisplayAlerts = True
Next x
End If
End Sub
laoau126
发表于 2015-6-18 07:21
122333