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

chenzhi_juan

Sub 按钮2_单击()

Dim x As Integer, a As Integer

If IsNull(Range("a1:a15").MergeCells) Then

   Range("a1:a15").UnMerge
   
   End
   
   Else

a = 2

For x = 2 To 15

    If Range("a" & x) <> Range("a" & x + 1) Then
   
       Application.DisplayAlerts = False
   
        Range("a" & a & ":" & "a" & x).Merge
        
        Application.DisplayAlerts = True
        
        a = x + 1
        
     End If
     
Next

End If

End Sub
Sub 第一题_按钮2_单击()

  Dim rg As Range, x As Integer, r, a As Integer
  Range("c1:f5").ClearContents '清除原始数据
   Set rg = Range("a1")
   Set rg = Cells.Find(what:="A", after:=rg.Offset(1, 0), MatchCase:=True, LookAt:=xlWhole, SearchDirection:=xlNext) '从a2后面开始查找
   
      a = 2 '设置初始值为第二行
  Do
    x = x + 1
   
    r = rg.Row '将查找到的行数赋值于r
   
    Range("a" & a & ":" & "a" & r - 1).Copy Cells(1, x + 2) '将第二个查找到的位置前一位连同A进行复制
   
    a = r  '重新赋值下一个A的位置
   
    Set rg = Columns("a").Find(what:="A", after:=rg, MatchCase:=True, LookAt:=xlWhole, SearchDirection:=xlNext)
   
  Loop Until rg.Row < r '当最后一个查找完毕后，EXCEL又会从头找起，这时，找到的行数小于最后一个A的位置，结束查找
           
  Range("a" & a & ":" & "a" & Range("a" & Cells.Rows.Count).End(xlUp).Row).Copy Cells(1, x + 3)  '因为没有找到下一个目标，变量x的值不会再增长，所以此时的列位置为x+3

End Sub

H:19 chenzhi_juan

byhdch

A09:byhdch
Sub 第二题合并()
    Dim i, qi, zh As Integer
    Dim StrMer, IntCot As String
    Application.DisplayAlerts = False
    With ActiveSheet
        If IsNull(Range("a2:c15").MergeCells) = False Then  
        qi = 2
            For i = 2 To .Range("a65536").End(xlUp).Row
                If Range("A" & i) = Range("A" & i + 1) Then
                Else
                    zh = i   
                Range("A" & qi & ":A" & zh).Select
                    With Selection
                        .MergeCells = True
                    End With
                    qi = i + 1
                End If
            Next i
        Else
            For i = 2 To .Range("a65536").End(xlUp).Row
                StrMer = .Range("A" & i).Value
                IntCot = .Range("A" & i).MergeArea.Count
                .Range("A" & i).UnMerge
                .Range(.Range("A" & i), .Range("A" & i + IntCot - 1)).Value = StrMer
                i = i + IntCot - 1
            Next i
        End If
    End With
    Application.DisplayAlerts = True
End Sub

vba第12课作业 A09byhdch.rar (9.84 KB, 下载次数: 2)

2012-4-23 23:11 上传

点击文件名下载附件

1982zyh

1. Sub 按钮2_单击()
   
2. 
   
3. Dim m As Integer, n As Integer, k As Integer
   
4. 
   
5. Application.DisplayAlerts = False
   
6. 
   
7. 'n = Range("a65536").End(xlUp).Row
   
8. 
   
9. n = ActiveSheet.UsedRange.Rows.Count
   
10. 
    
11. If IsNull(Range("a:a").MergeCells) = True Then
    
12. 
    
13.     Range("a:a").UnMerge
    
14.    
    
15.     For m = 2 To n
    
16.    
    
17.         If Cells(m, 1) = "" Then
    
18.             
    
19.             Cells(m, 1) = Cells(m - 1, 1)
    
20.                               
    
21.         End If
    
22.    
    
23.     Next m
    
24.    
    
25. Else
    
26. 
    
27. k = 2
    
28. 
    
29.     For m = 3 To n + 1
    
30.    
    
31.         If Cells(m, 1) <> Cells(m - 1, 1) Then
    
32.             
    
33.             Range(Cells(k, 1), Cells(m - 1, 1)).Merge
    
34.             
    
35.             k = m
    
36.         
    
37.         End If
    
38.    
    
39.     Next m
    
40.       
    
41. End If
    
42. 
    
43. Application.DisplayAlerts = True
    
44. 
    
45. End Sub
    
46. Sub 第一题_按钮2_单击()
    
47. 
    
48. Dim rg As Range, r As Integer, m As Integer, n As Integer, rr As Integer
    
49. n = 3
    
50. m = Range("a65536").End(xlUp).Row
    
51. Set rg = Range("a1")
    
52. Set rg = Range("a:a").Find("A", after:=rg, MatchCase:=True, LookAt:=xlWhole, SearchDirection:=xlNext)
    
53. r = rg.Row
    
54. Do
    
55.    
    
56.     Set rg = Range("a:a").Find("A", after:=rg, MatchCase:=True, LookAt:=xlWhole, SearchDirection:=xlNext)
    
57.    
    
58.     rr = rg.Row
    
59.    
    
60.     If rg.Row > r Then
    
61.    
    
62.         Range(Cells(r, 1), Cells(rg.Row - 1, 1)).Copy Cells(1, n)
    
63.         
    
64.         r = rr
    
65.             
    
66.         n = n + 1
    
67.    
    
68.     Else
    
69.    
    
70.         Range(Cells(r, 1), Cells(m, 1)).Copy Cells(1, n)
    
71. 
    
72.     End If
    
73.         
    
74. Loop Until r > rg.Row
    
75. 
    
76. End Sub
    

复制代码

bl5062

1. 
   
2. Option Explicit
   
3. 
   
4. Sub 按钮2_单击()
   
5.     Dim i As Long, previous As Long
   
6.     Application.DisplayAlerts = False
   
7.     previous = 2
   
8.     For i = 3 To 16
   
9.         If (Cells(i, 1) <> "" And Cells(i, 1) <> Cells(i - 1, 1)) Or i = 16 Then
   
10.             With Cells(previous, 1).Resize(i - previous)
    
11.                 If .MergeCells Then
    
12.                     .UnMerge
    
13.                     .FillDown
    
14.                 Else
    
15.                     .Merge
    
16.                 End If
    
17.             End With
    
18.             Debug.Print Cells(previous, 1).Resize(i - previous).Address()
    
19.             previous = i
    
20.         End If
    
21.     Next i
    
22.     Application.DisplayAlerts = True
    
23. End Sub
    
24. Sub 第一题_按钮2_单击()
    
25.     Dim i As Long, j As Long, previous As Long
    
26.     Dim buf
    
27.     previous = 2
    
28.     j = 3
    
29.     For i = 3 To Cells(Rows.Count, 1).End(3).Row + 1
    
30.         If Cells(i, 1) = "A" Or i = Cells(Rows.Count, 1).End(3).Row + 1 Then
    
31.             buf = Cells(previous, 1).Resize(i - previous)
    
32.             'Debug.Print Cells(previous, 1).Resize(i - previous).Address()
    
33.             Cells(1, j).Resize(i - previous) = buf
    
34.             j = j + 1
    
35.             previous = i
    
36.         End If
    
37.     Next i
    
38. End Sub
    

复制代码

兰江自由鱼

D15兰江自由鱼_vba第12课作业.rar (12.45 KB, 下载次数: 2)

2012-4-24 00:32 上传

点击文件名下载附件 请批改，谢谢！
Sub 第一题_按钮2_单击()
    Dim rg As Range, x As Integer, y As Integer, i As Integer, n As Integer

    Range("c:f").Clear
    Set rg = Range("A:A").Find("A", lookat:=xlWhole)
    x = rg.Row
    n = x
    Do
        Set rg = Columns("A").Find("A", after:=rg, MatchCase:=True, lookat:=xlWhole, searchdirection:=xlNext)
        y = rg.Row
        If x < y Then
            Range(Cells(x, "a"), Cells(y - 1, "A")).Copy Range("A1").Offset(, 2 + i)
            i = i + 1
            x = y
        End If
    Loop Until y = n
    y = Range("a65535").End(xlUp).Row
    Range(Cells(x, "a"), Cells(y, "A")).Copy Range("A1").Offset(, 2 + i)
    '  Stop
End Sub

Sub 按钮2_单击()
    Dim rg As Range, x As Integer, y As Integer, i As Integer, n As Integer
    Application.DisplayAlerts = False
    If IsNull(Range("a:a").MergeCells) Then
        Range("a:a").UnMerge
        Range("A1:A15").SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
     Else
        n = Range("a65535").End(xlUp).Row
        x = 2
        Do While x < n
            Set rg = Range("A" & x)
            i = x
            Do
                Set rg = Range("A:A").Find(Range("A" & x), after:=rg, MatchCase:=True, LookIn:=xlValues, lookat:=xlWhole, searchdirection:=xlNext)
                y = rg.Row
                If i < y Then
                    x = y
                End If
            Loop Until y = i
            Range("A" & i & ":A" & x).Merge
            x = x + 1
        Loop
     End If
     Application.DisplayAlerts = True
    End Sub

sliang28

C09:sliang28
第一题代码：

1. Sub 第一题_按钮2_单击()
   
2. Dim a(20, 20) As String
   
3. Dim b(20, 20) As String
   
4. Dim dyg As Range
   
5. Dim i!, j!
   
6. i = 0
   
7. For Each dyg In [A2:A18]
   
8. If dyg = "A" Then
   
9. i = i + 1
   
10. j = 0
    
11. b(i, j) = dyg
    
12. j = j + 1
    
13. Else
    
14. b(i, j) = dyg
    
15. j = j + 1
    
16. End If
    
17. Next
    
18. For i = 1 To 10
    
19. For j = 0 To 10
    
20. Sheet1.Cells(j + 1, i + 2) = b(i, j)
    
21. Next j
    
22. Next i
    
23. End Sub

复制代码

第二题代码：(校长，这题我不明白什么叫合并同类项，意思不理解。在我影响当中合并同类项是：比如{3A;3C;2A;2C},合并同类项变成{5A;5C},因为题意不理解，我是按照合并单元格写的，点击一下合并，再点击一下拆分)

1. Sub 按钮2_单击()
   
2. Application.DisplayAlerts = False
   
3. Dim k, i As Integer
   
4. Dim c As Range
   
5. Dim first, last As Integer
   
6. k = 2
   
7. If Sheet2.Cells(k, 1).MergeCells Then
   
8. For Each c In [a2:a16]
   
9. If c.MergeCells Then
   
10. c.Select
    
11. c.UnMerge
    
12. Selection.Value = c.Value
    
13. End If
    
14. Next c
    
15. Else
    
16. first = 1
    
17. For i = 1 To 20 Step 1
    
18. If Sheet2.Range("A" & i) = Sheet2.Range("A" & i + 1) Then
    
19. Else
    
20. last = i
    
21. Sheet2.Range("A" & first & ":A" & last).Select
    
22. Selection.Merge
    
23. first = i + 1
    
24. End If
    
25. Next
    
26. End If
    
27. Application.DisplayAlerts = True
    
28. End Sub

复制代码

ls

游客，如果您要查看本帖隐藏内容请回复

hactnet

H组 H15:hactnet
交下作业，请老师检查！

Sub 按钮2_单击()

Dim tt As String
Dim x As Integer, y As Integer
Application.DisplayAlerts = False

If IsNull(Range("a:a").MergeCells) Then                 '判断A列是否有合并单元格

For x = 2 To Range("a65536").End(xlUp).Row
tt = Cells(x, 1)                                        '记录值
y = Cells(x, 1).MergeArea.Count                         '合并单元格计数
Cells(x, 1).UnMerge                                     '解除合并
Range(Cells(x, 1), Cells(x + y - 1, 1)) = tt            '解除合并的单元格取值
x = x + y - 1
Next x

Else

For x = Range("a65536").End(xlUp).Row To 2 Step -1      '倒循环防止多行相同合并时，首次合并后下次合并时出错
If Cells(x, 1) = Cells(x - 1, 1) Then                   '判断相邻单元格是否相等
Range(Cells(x - 1, 1), Cells(x, 1)).Merge               '合并相邻单元格
End If
Next x
End If

Application.DisplayAlerts = True

End Sub

'*************************************
Sub 第二题方法2()

Dim x
Application.DisplayAlerts = False
    If IsNull(Range("a:a").MergeCells) Then Range("a:a").UnMerge
   
    For x = Range("a65536").End(xlUp).Row To 2 Step -1
        If Cells(x, 1) = Cells(x - 1, 1) Then Range(Cells(x - 1, 1), Cells(x, 1)).Merge
    Next x
    Application.DisplayAlerts = True
End Sub
'************************************


Sub 第一题_按钮2_单击()

  Dim rg As Range, x As Integer, r, y, 目标区列总数, 目标区开始列
   Range("c1:f10") = ""
   Set rg = Range("a1")
   
   目标区列总数 = Application.CountIf(Range("A:A"), "A")
   目标区开始列 = 3
   
   r = Range("A:A").Find("A", LookAt:=xlWhole).Row              '第一个A
   
   For x = 2 To 目标区列总数
   
        y = r
        Set rg = Cells.Find("A", after:=rg.Offset(1, 0), MatchCase:=True, LookAt:=xlWhole, SearchDirection:=xlNext)
        r = rg.Row
        Cells(y, 1).Resize(r - y).Copy Cells(1, 目标区开始列)
        目标区开始列 = 目标区开始列 + 1
   Next x
   Cells(r, 1).Resize(Range("A65536").End(xlUp).Row).Copy Cells(1, 目标区开始列)

End Sub

szczm121

g17:szczm121 vba第12课作业szczm121.rar (11.49 KB, 下载次数: 2)

2012-4-24 17:25 上传

点击文件名下载附件
Sub 按钮2_单击()
Dim s As Integer, q As Integer, x As Integer
q = Range("A65536").End(xlUp).Row + 1
   Application.DisplayAlerts = False
   x = 2
  If IsNull(Range("a2:a" & q - 1).MergeCells) = False Then
     For s = 2 To q
         If Range("a" & s + 1) <> Range("a" & s) Then
         Range("a" & x & ":a" & s).Merge
          x = s + 1
         End If
    Next s
  Else
  Range("a2:a" & q - 1).UnMerge
  End If
Application.DisplayAlerts = True
End Sub
Sub 第一题_按钮2_单击()
Dim sz As Integer, m As Integer
Dim c As Integer, z As Integer
c = Sheets("第一题").Range("a65536").End(xlUp).Row + 1
  sz = 2
    With Sheets("第一题")
      For m = 3 To c
        z = m
      Do Until .Cells(m, 1) = "A" Or .Cells(m, 1) = ""
        m = m + 1
      Loop
        sz = sz + 1
     .Cells(z - 1, 1).Resize(m - z + 1, 1).Copy Cells(1, sz)
   Next m
End With
End Sub

vbamaster

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

2012-4-24 19:52 上传

点击文件名下载附件
第一题：
Sub 按钮2_单击()
    Dim rg1 As Range, rg2 As Range
    Dim x, y As Integer
    Application.ScreenUpdating = False
    For x = 2 To Application.Match("A", Range("a:a"), 0) + 2
        If rg1 Is Nothing Or rg2 Is Nothing Then
            Set rg1 = Range("a:a").Find("A", lookat:=xlWhole, searchdirection:=xlNext, MatchCase:=True)
            y = rg1.Row
            Set rg2 = Range("a:a").Find("A", after:=rg1, lookat:=xlWhole, searchdirection:=xlNext, MatchCase:=True)
            rg1.Resize(rg2.Row - rg1.Row, 1).Copy Cells(1, x + 1)
        ElseIf rg1.Row < rg2.Row Then
            Set rg1 = Range("a:a").Find("A", after:=rg2, lookat:=xlWhole, searchdirection:=xlNext, MatchCase:=True)
            rg2.Resize(rg1.Row - rg2.Row, 1).Copy Cells(1, x + 1)
        Else
            Set rg2 = Range("a:a").Find("A", after:=rg1, lookat:=xlWhole, searchdirection:=xlNext, MatchCase:=True)
            rg1.Resize(rg2.Row - rg1.Row, 1).Copy Cells(1, x + 1)
        End If
    Next x
    Set rg1 = Range("a:a").Find("A", after:=Range("a" & Rows.Count), lookat:=xlWhole, searchdirection:=xlPrevious, MatchCase:=True)
    rg1.Resize(Range("a" & Rows.Count).End(xlUp).Row - rg1.Row + 1, 1).Copy Cells(1, x + 1)
    Application.ScreenUpdating = False
End Sub
第二题：
Sub 第一题_按钮2_单击()
    Dim rg, rg1 As Range
    Application.DisplayAlerts = False
    If IsNull(Range("a2:a15").MergeCells) Then
        Range("a2:a15").UnMerge
    Else
        Set rg1 = Range("a2")
        For Each rg In Range("a2:a15")
            If rg.Offset(1, 0) <> rg1 Then
                Range("a" & rg1.Row & " :a" & rg.Row).Merge
                Set rg1 = rg.Offset(1, 0)
            End If
        Next rg
    End If
    Application.DisplayAlerts = True
End Sub
D05:vbamaster