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

冠军欧洲2010

说明:
统计帖每个学员只能跟帖回复一次，也就是在原来回复楼层的基础上点编缉，不要一个链接一层楼，否则不计算积分。
各小组学员上交作业时，一定要点击“我要参加”，并注明自己的新组编号和论坛ID，如果点击过“我要参加”但没有跟帖提交作业的，扣该学员5积分；如果跟帖提交了作业，但没有点“我要参加”的，不给予评分。

请各学员看清上面的说明，免得被扣了分分！
本帖为仅楼主可见帖，直接回复即可！
作业链接：http://www.excelpx.com/thread-238836-1-1.html

hrpotter

C12:hrpotter

1. Option Explicit
   
2. Sub 拆分()
   
3.     Dim i As Integer, j As Integer
   
4.     Dim rg As Range
   
5.     Dim firstaddress As String
   
6.     Range("c:iv").Clear
   
7.     Set rg = Range("a:a").Find("A")
   
8.     If Not rg Is Nothing Then
   
9.         firstaddress = rg.Address
   
10.         j = rg.Row
    
11.         Do
    
12.             i = i + 1
    
13.             Set rg = Range("a:a").FindNext(rg)
    
14.             If rg.Address <> firstaddress Then
    
15.                 Range(Cells(j, 1), Cells(rg.Row - 1, 1)).Copy Cells(1, 2 + i)
    
16.             Else
    
17.                 Range(Cells(j, 1), Range("a65536").End(xlUp)).Copy Cells(1, 2 + i)
    
18.             End If
    
19.             j = rg.Row
    
20.         Loop While Not rg Is Nothing And rg.Address <> firstaddress
    
21.     End If
    
22. End Sub
    
23. Sub 合并()
    
24.     Dim i As Integer
    
25.     If IsNull(Range("a1").CurrentRegion.MergeCells) Then
    
26.         Range("a1").CurrentRegion.UnMerge
    
27.     Else
    
28.         For i = Range("a65536").End(xlUp).Row To 2 Step -1
    
29.             If Cells(i, 1) = Cells(i - 1, 1) Then
    
30.                 Application.DisplayAlerts = False
    
31.                 Range(Cells(i - 1, 1), Cells(i, 1)).Merge
    
32.                 Application.DisplayAlerts = True
    
33.             End If
    
34.         Next
    
35.     End If
    
36. End Sub

复制代码

C12-hrpotter-vba第12课作业.rar (8.85 KB, 下载次数: 16)

2012-4-21 20:20 上传

点击文件名下载附件

dsjohn

Sub 第一题()
Dim Lrow As Long
Dim Lcol As Long, M
Lcol = 2
For Lrow = 2 To Range("A65536").End(3).Row
    If Range("a" & Lrow).Value = "A" Then
        M = 1
        Lcol = Lcol + 1
        Cells(1, Lcol) = Range("a" & Lrow)
    Else
        M = M + 1
        Cells(M, Lcol) = Range("a" & Lrow)
    End If
Next Lrow
End Sub
第二题
Sub 按钮2_单击()
Dim Lrow As Long, M, Y
Application.DisplayAlerts = False
    Y = Range("a65536").End(3).Row
    If IsNull(Range(Cells(1, "a"), Cells(Y, "a")).MergeCells) = False Then
        For Lrow = 2 To Y
        If Range("A" & Lrow) = Range("A" & Lrow + 1) Then
            M = M + 1
        Else
            Range(Cells(Lrow - M, "a"), Cells(Lrow, "a")).Merge
            M = 0
        End If
        Next Lrow
    Else
        Range(Cells(1, "a"), Cells(Y, "a")).UnMerge
    End If
Application.DisplayAlerts = True
End Sub

sunjing-zxl

E学委:sunjing-zxl
vba第12课作业-E学委-sunjing-zxl.rar (12.21 KB, 下载次数: 6)

2012-4-22 18:19 上传

点击文件名下载附件

ybchxj2010

1. Option Explicit
   
2. Public U%
   
3. '合并同类项
   
4. Sub Merge_RNG()
   
5. 
   
6.       Dim R As Integer
   
7.       Dim i As Integer
   
8.       Application.DisplayAlerts = False
   
9.       With Sheets("第二题")
   
10.           R = .Range("A65536").End(xlUp).Row
    
11.           For i = R To 2 Step -1
    
12.               If .Cells(i, 1).Value = .Cells(i - 1, 1).Value Then
    
13.                   .Range(.Cells(i - 1, 1), .Cells(i, 1)).Merge
    
14.               End If
    
15.           Next
    
16.       End With
    
17.       Application.DisplayAlerts = True
    
18. End Sub
    
19. '取消合并
    
20. Sub UnMerge_RNG()
    
21.       Dim STR As String
    
22.       Dim T As Integer
    
23.       Dim i As Integer
    
24.       With Sheets("第二题")
    
25.           For i = 2 To .Range("A65536").End(xlUp).Row
    
26.               STR = .Cells(i, 1).Value
    
27.               T = .Cells(i, 1).MergeArea.Count
    
28.               .Cells(i, 1).UnMerge
    
29.               .Range(.Cells(i, 1), .Cells(i + T - 1, 1)).Value = STR
    
30.               i = i + T - 1
    
31.           Next
    
32.       End With
    
33.   End Sub
    
34. Sub 第二题()
    
35.     If IsNull(Range("A2:A" & [A65536].End(3).Row).MergeCells) Then
    
36.         Call UnMerge_RNG
    
37.     Else
    
38.         Call Merge_RNG
    
39.     End If
    
40. End Sub
    
41. Sub 第一题()
    
42. 
    
43. U = (U + 1) Mod 2
    
44. 
    
45. If U = 1 Then
    
46.     Call RF
    
47.     MsgBox "这是用正则完成的!"
    
48. Else
    
49.     Call FF
    
50.     MsgBox "这是用FIND完成的!"
    
51. End If
    
52. 
    
53. End Sub
    
54. '投机取巧法,目的复习正则表达式
    
55. Sub RF()
    
56. Dim STR As String
    
57. Dim i, J As Integer
    
58. Dim arr, K, M
    
59. Dim rg
    
60. 
    
61. Set rg = CreateObject("VBScript.RegExp")
    
62. arr = Range("a2:a" & [A65536].End(3).Row)
    
63. STR = Join(Application.Transpose(arr), "@")
    
64. 
    
65. With rg
    
66.     .Global = True
    
67.     .Pattern = "\bA[^A]+\b"
    
68.     Set K = .Execute(STR)
    
69. End With
    
70. 
    
71. J = 3
    
72. For i = 0 To K.Count - 1
    
73.     M = Application.Transpose(Split(K(i), "@"))
    
74.     Cells(1, J).Resize(UBound(M), 1) = M
    
75.     J = J + 1
    
76. Next
    
77. End Sub
    
78. 'FIND方法
    
79. Sub FF()
    
80.     Dim Cel1, Cel2, RNG As Range
    
81.     Dim i, R, C As Integer
    
82.     i = Application.CountIf(Range("A:A"), "A")
    
83.     C = 3
    
84.     Set Cel1 = Range("A2")
    
85.     With Range("A:A")
    
86.     For R = 1 To i
    
87.         Set Cel2 = .Find(What:="A", After:=Cel1, LookIn:=xlValues, LookAt:=xlWhole)
    
88.         If Cel2.Address = "$A$2" Then Set Cel2 = [A65536].End(3).Offset(1, 0)
    
89.         Set RNG = Range(Cel1, Cel2.Offset(-1, 0))
    
90.         RNG.Copy Cells(1, C)
    
91.         C = C + 1
    
92.         Set Cel1 = Cel2
    
93.     Next
    
94. 
    
95.     End With
    
96. End Sub
    

复制代码

我不知道呀

Sub 第一题()
    Range("c1:f5").ClearContents
    Dim i As Integer
    Dim j As Integer
    Dim x As Integer
    Dim y As Integer
    Dim arr
    i = Range("a65536").End(xlUp).Row
    For j = i To 2 Step -1
        y = y + 1
        If Cells(j, 1) = "A" Then
            arr = Range(Cells(j, 1), Cells(i, 1))
            [f1].Offset(0, -x).Resize(y, 1) = arr
            x = x + 1
            y = 0
        End If
    Next j
End Sub
'---------------------------------------------------------------------------
Sub 第二题()
    Dim r As Integer
    Dim i As Integer
    Dim mergestr As String
    Dim mergecot As Integer
    If [a3] <> "" Then
        Application.DisplayAlerts = False
        With Sheet2
            r = .Cells(Rows.Count, 1).End(xlUp).Row
            For i = r To 2 Step -1
                If .Cells(i, 1).Value = .Cells(i - 1, 1).Value Then
                    .Range(.Cells(i - 1, 1), .Cells(i, 1)).Merge
                End If
            Next
        End With
        Application.DisplayAlerts = True
    Else
        With Sheet2
            r = .Cells(.Rows.Count, 1).End(xlUp).Row
            For i = 2 To r
                mergestr = .Cells(i, 1).Value
                mergecot = .Cells(i, 1).MergeArea.Count
                .Cells(i, 1).UnMerge
                .Range(.Cells(i, 1), .Cells(i + mergecot - 1, 1)).Value = mergestr
                i = i + mergecot - 1
            Next
        End With
    End If
End Sub

qushui

A学委:qushui

1. Sub 第一题_单击()
   
2.     Dim rg1 As Range, rg2 As Range, f As String, x As Integer
   
3.     With Sheets("第一题")
   
4.         .Range(.Cells(1, 2), .Cells(10, 50)).Clear
   
5.         Set rg1 = .Columns(1).Find(what:="A", after:=.[a1], Lookat:=xlWhole, MatchCase:=True)
   
6.         f = rg1.Address
   
7.         x = 1
   
8.         Do
   
9.             x = x + 1
   
10.             Set rg2 = .Columns(1).FindNext(rg1)
    
11.             If rg2.Address <> f Then
    
12.                 .Range(rg1, rg2.Offset(-1, 0)).Copy .Cells(1, x)
    
13.                 Set rg1 = rg2
    
14.             Else
    
15.                 .Range(rg1, .[a65536].End(3)).Copy .Cells(1, x)
    
16.             End If
    
17.         Loop Until rg2.Address = f
    
18.     End With
    
19. End Sub
    
20. [code]Sub 第二题_单击()
    
21.     Dim m%, n%, i%
    
22.     Application.DisplayAlerts = False
    
23.     With Sheets("第二题")
    
24.         m = 2
    
25.         For i = 2 To .[a65536].End(3).Row - 1
    
26.             If .Cells(i + 1, 1) <> "" And .Cells(i, 1) <> .Cells(i + 1, 1) Then
    
27.                 n = i
    
28.                 If .Range(.Cells(m, 1), .Cells(n, 1)).MergeCells Then
    
29.                     .Range(.Cells(m, 1), .Cells(n, 1)).UnMerge
    
30.                     .Range(.Cells(m, 1), .Cells(n, 1)) = .Cells(m, 1).Value
    
31.                 Else
    
32.                     .Range(.Cells(m, 1), .Cells(n, 1)).Merge
    
33.                 End If
    
34.                 m = i + 1
    
35.             End If
    
36.             If i = .[a65536].End(3).Row - 1 Then
    
37.                 If .Cells(m, 1).MergeArea.Address <> .Cells(m, 1).Address Then
    
38.                     .Cells(m, 1).MergeArea.Select
    
39.                     Selection.UnMerge
    
40.                     Selection = .Cells(m, 1).Value
    
41.                 Else
    
42.                     .Range(.Cells(m, 1), .[a65536].End(3)).Merge
    
43.                 End If
    
44.             End If
    
45.         Next i
    
46.     End With
    
47.     Application.DisplayAlerts = True
    
48. End Sub

复制代码

[/code]

yl_li

第2题的思路实在是不满意 vba第12课作业.rar (12.68 KB, 下载次数: 2)

2012-4-23 14:41 上传

点击文件名下载附件
Sub 第二题()
Dim I As Long
Application.DisplayAlerts = False
    If IsNull(Range("a2").CurrentRegion.MergeCells) = False Then
        For I = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
            If Cells(I, 1) = Cells(I - 1, 1) Then
                Range(Cells(I, 1), Cells(I - 1, 1)).Merge
            End If
        Next I
    Else
        For I = 2 To Range("A" & Rows.Count).End(xlUp).Row
            If WorksheetFunction.CountA(Range("a" & I & ":a" & I + 1)) = 1 Then
                Range(Cells(I, 1), Cells(I + 1, 1)).UnMerge
                Cells(I + 1, 1) = Cells(I, 1)
            End If
        Next I
    End If
Application.DisplayAlerts = True
End Sub
Sub 第一题()
Dim rng1 As Range, rng2 As Range, I As Byte
Set rng1 = Range("a2")
I = 3
    Do
        Set rng2 = Range("a2:a18").Find("A", after:=rng1)
            If rng2.Row > rng1.Row Then
                rng1.Resize(rng2.Row - rng1.Row).Copy Cells(1, I)
                Set rng1 = rng2
                I = I + 1
            Else
                rng1.Resize(19 - rng1.Row).Copy Cells(1, I)
            End If
    Loop Until rng1.Row > rng2.Row
End Sub

yu20078

Sub 按钮2_单击() '题二
Application.DisplayAlerts = False
Dim i, rng As Range, x
With Range("a2:a" & Range("a" & Rows.Count).End(xlUp).Row + 1)
    If IsNull(.MergeCells) = False Then    '合并
        Set rng = [a2]
        For i = 2 To .Rows.Count
            If Cells(i, 1) = Cells(i + 1, 1) Then
                Set rng = Union(rng, Cells(i + 1, 1))
            Else
                rng.Merge
                Set rng = Cells(i + 1, 1)
            End If
         Next i
    Else                                   '拆分
        .UnMerge
        x = [a2]: Set rng = Nothing
        For Each rng In Range("a3:a" & Range("a" & Rows.Count).End(xlUp).Row + 1)
            If rng = "" Then
                rng = x
            Else
                x = rng
            End If
        Next rng
    End If
Application.DisplayAlerts = True
End With
End Sub

Sub 第一题_按钮2_单击()
Dim 始 As Range, 末 As Range, 保持 As Range
Dim 查找值总数&, 查找值$, 循环&
查找值 = "A"                                                                   ' 可用inputbox来引入值
查找值总数 = WorksheetFunction.CountIf(Range("a1").CurrentRegion, 查找值)
With Range("a1").CurrentRegion
    Set 始 = .Find(查找值, LOOKAT:=xlWhole)                 '赋值区域中第一个符合条件的单元格
    If 始 Is Nothing Then                                                  '如果区域中查找不着的处理
        MsgBox "区域中没有查找值" & 查找值
        Exit Sub
    Else
        Set 保持 = 始                                                        '赋值第一个符合条件的单元格(此变量固定不动)
        For 循环 = 3 To 2 + 查找值总数                           '建立循环
            Set 末 = .FindNext(始)                                      '从第一个查找到后面继续查找下一个
            If 保持.Row = 末.Row Then                               '如果下一个查找到的单元格的行和第一个单元格一样
                始.Resize(.Rows.Count - 始.Row + 1).Copy   '复制当前的 始 至当前区域的末单元格区域
            Else
                始.Resize(末.Row - 始.Row).Copy                 '复制当前的 始 至 当前的 末 之间的单元格区域
                Set 始 = 末                                                  '重置变量 始
            End If
            Cells(1, 循环).Select                                          '粘贴
            ActiveSheet.Paste
        Next 循环
    End If
End With
End Sub
yu20078-第12课作业.rar (9.33 KB, 下载次数: 6)

2012-4-23 14:54 上传

点击文件名下载附件

jxncfxsf

Sub 按钮2_单击()
Dim q, i, n As Long
Dim rg As Range
Dim str As String
If IsNull(Range("a:a").MergeCells) Then
q = 1
Do
q = q + 1
If Range("a" & q).MergeCells = True Then
str = Range("a" & q).MergeArea.Address
Range("a" & q).UnMerge

Range(str) = Range("a" & q)
End If
Loop Until Range("a" & q) = ""

Else
Set rg = Range("a1")
Application.DisplayAlerts = False
Do
i = rg.Row + 1
Set rg = Range("A:A").Find(what:=rg.Offset(1, 0), after:=Range("a65536"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
n = rg.Row
Range(Cells(i, 1), Cells(rg.Row, 1)).Merge
Loop Until rg.Offset(1, 0) = ""
Application.DisplayAlerts = True
End If
End Sub
Sub 第一题_按钮2_单击()
Dim i, n As Long
Dim rg As Range
n = 1
Set rg = Range("a:a").Find("A", after:=Range("a1"))
Do
n = n + 1
i = rg.Row
Set rg = Range("A:a").Find("A", after:=rg.Offset(1, 0))
If rg.Row < i Then
   Range("a" & i & ":A" & Range("a" & Rows.Count).End(xlUp).Row).Copy Range("a1").Offset(0, n)
   Else
Range("a" & i & ":A" & rg.Row - 1).Copy Range("a1").Offset(0, n)
End If

Loop Until rg.Row < i
End Sub