[通知] 统计VBA学习小组正式组的积分帖之作业上交贴（第15周）

梅一枝

梅一枝vba12讲单元格查找与合并题.rar (8.71 KB, 下载次数: 3)

2012-4-25 23:05 上传

点击文件名下载附件
在老师的带领下，又温习一次DO语句。

Iweb002

坚持学习，总有收获。

君子豹变

老师，上一课作业我不会做，听完课后才做。现交如下
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
vba第12课作业.rar (9.51 KB, 下载次数: 3)

2012-4-26 13:32 上传

点击文件名下载附件

本节课数组的作业
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
13课作业.rar (8.22 KB, 下载次数: 3)

2012-4-26 13:44 上传

点击文件名下载附件

想飞的鸟

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

不好意思，上次可没来听，作业没及时完成，补交
vba第12课作业-B06-liuho1.zip (12.6 KB, 下载次数: 3)

2012-4-27 15:27 上传

点击文件名下载附件

libenwen2011

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

老师你好，对不起，搞忘了写论坛ID号，现在补上，我的新组编号没有找到，27楼是我的作业
libenwen2011   (UID: 514207)
一直都在忙，今天才能抽空完成作业
谢谢老师体谅！！

libenwen2011

对不起，搞错了，第16周的作业

gaoshuichang1

vba第12课作业.rar (8.43 KB, 下载次数: 3)

2012-4-29 21:12 上传

点击文件名下载附件

1. Sub 第一题_按钮2_单击()
   
2. Dim x As Integer, 开始行数, 结束行数
   
3. Dim rg As Range, rg1 As Range, y As Integer, k As Integer
   
4. Set rg = Range("a1")
   
5. Do
   
6.    k = k + 1
   
7.    Set rg = Range("a:a").Find("A", after:=rg, lookat:=xlWhole)
   
8.    开始行数 = rg.Row
   
9.    Set rg1 = Range("a:a").Find("A", after:=rg, lookat:=xlWhole)
   
10.    If rg1.Row < 开始行数 Then
    
11.       结束行数 = Range("A65536").End(xlUp).Row
    
12.    Else
    
13.       结束行数 = rg1.Row - 1
    
14.    End If
    
15.    Range(Cells(开始行数, 1), Cells(结束行数, 1)).Copy Cells(1, k + 2)
    
16. Loop Until rg1.Row < 开始行数
    
17. End Sub
    

复制代码

1. Sub 按钮2_单击()
   
2.   Dim x As Integer, 开始行数 As Integer
   
3.   If IsNull(Range("a1:a15").MergeCells) = True Then
   
4.     Range("a1:a15").UnMerge
   
5.   Else
   
6.     For x = 2 To Range("a65536").End(xlUp).Row
   
7.        开始行数 = x
   
8.        Do
   
9.          x = x + 1
   
10.        Loop Until Cells(x + 1, 1) <> Cells(x, 1)
    
11.        Application.DisplayAlerts = False
    
12.          Range(Cells(开始行数, 1), Cells(x, 1)).Merge
    
13.        Application.DisplayAlerts = True
    
14.     Next x
    
15.   End If
    
16. End Sub

复制代码

laoau126

122333