[通知] 统计VBA学习小组正式组的积分帖之作业上交贴（第15周）
本帖最后由 冠军欧洲2010 于 2012-5-9 07:58 编辑说明:
统计帖每个学员只能跟帖回复一次，也就是在原来回复楼层的基础上点编缉，不要一个链接一层楼，否则不计算积分。
各小组学员上交作业时，一定要点击“我要参加”，并注明自己的新组编号和论坛ID，如果点击过“我要参加”但没有跟帖提交作业的，扣该学员5积分；如果跟帖提交了作业，但没有点“我要参加”的，不给予评分。
请各学员看清上面的说明，免得被扣了分分！
本帖为仅楼主可见帖，直接回复即可！
作业链接：http://www.excelpx.com/thread-238836-1-1.html C12:hrpotterOption Explicit
Sub 拆分()
Dim i As Integer, j As Integer
Dim rg As Range
Dim firstaddress As String
Range("c:iv").Clear
Set rg = Range("a:a").Find("A")
If Not rg Is Nothing Then
firstaddress = rg.Address
j = rg.Row
Do
i = i + 1
Set rg = Range("a:a").FindNext(rg)
If rg.Address <> firstaddress Then
Range(Cells(j, 1), Cells(rg.Row - 1, 1)).Copy Cells(1, 2 + i)
Else
Range(Cells(j, 1), Range("a65536").End(xlUp)).Copy Cells(1, 2 + i)
End If
j = rg.Row
Loop While Not rg Is Nothing And rg.Address <> firstaddress
End If
End Sub
Sub 合并()
Dim i As Integer
If IsNull(Range("a1").CurrentRegion.MergeCells) Then
Range("a1").CurrentRegion.UnMerge
Else
For i = Range("a65536").End(xlUp).Row To 2 Step -1
If Cells(i, 1) = Cells(i - 1, 1) Then
Application.DisplayAlerts = False
Range(Cells(i - 1, 1), Cells(i, 1)).Merge
Application.DisplayAlerts = True
End If
Next
End If
End Sub 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
E学委:sunjing-zxl
Option Explicit
Public U%
'合并同类项
Sub Merge_RNG()
Dim R As Integer
Dim i As Integer
Application.DisplayAlerts = False
With Sheets("第二题")
R = .Range("A65536").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
End Sub
'取消合并
Sub UnMerge_RNG()
Dim STR As String
Dim T As Integer
Dim i As Integer
With Sheets("第二题")
For i = 2 To .Range("A65536").End(xlUp).Row
STR = .Cells(i, 1).Value
T = .Cells(i, 1).MergeArea.Count
.Cells(i, 1).UnMerge
.Range(.Cells(i, 1), .Cells(i + T - 1, 1)).Value = STR
i = i + T - 1
Next
End With
End Sub
Sub 第二题()
If IsNull(Range("A2:A" & .End(3).Row).MergeCells) Then
Call UnMerge_RNG
Else
Call Merge_RNG
End If
End Sub
Sub 第一题()
U = (U + 1) Mod 2
If U = 1 Then
Call RF
MsgBox "这是用正则完成的!"
Else
Call FF
MsgBox "这是用FIND完成的!"
End If
End Sub
'投机取巧法,目的复习正则表达式
Sub RF()
Dim STR As String
Dim i, J As Integer
Dim arr, K, M
Dim rg
Set rg = CreateObject("VBScript.RegExp")
arr = Range("a2:a" & .End(3).Row)
STR = Join(Application.Transpose(arr), "@")
With rg
.Global = True
.Pattern = "\bA[^A]+\b"
Set K = .Execute(STR)
End With
J = 3
For i = 0 To K.Count - 1
M = Application.Transpose(Split(K(i), "@"))
Cells(1, J).Resize(UBound(M), 1) = M
J = J + 1
Next
End Sub
'FIND方法
Sub FF()
Dim Cel1, Cel2, RNG As Range
Dim i, R, C As Integer
i = Application.CountIf(Range("A:A"), "A")
C = 3
Set Cel1 = Range("A2")
With Range("A:A")
For R = 1 To i
Set Cel2 = .Find(What:="A", After:=Cel1, LookIn:=xlValues, LookAt:=xlWhole)
If Cel2.Address = "$A$2" Then Set Cel2 = .End(3).Offset(1, 0)
Set RNG = Range(Cel1, Cel2.Offset(-1, 0))
RNG.Copy Cells(1, C)
C = C + 1
Set Cel1 = Cel2
Next
End With
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))
.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 <> "" 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
A学委:qushuiSub 第一题_单击()
Dim rg1 As Range, rg2 As Range, f As String, x As Integer
With Sheets("第一题")
.Range(.Cells(1, 2), .Cells(10, 50)).Clear
Set rg1 = .Columns(1).Find(what:="A", after:=., Lookat:=xlWhole, MatchCase:=True)
f = rg1.Address
x = 1
Do
x = x + 1
Set rg2 = .Columns(1).FindNext(rg1)
If rg2.Address <> f Then
.Range(rg1, rg2.Offset(-1, 0)).Copy .Cells(1, x)
Set rg1 = rg2
Else
.Range(rg1, ..End(3)).Copy .Cells(1, x)
End If
Loop Until rg2.Address = f
End With
End Sub
Sub 第二题_单击()
Dim m%, n%, i%
Application.DisplayAlerts = False
With Sheets("第二题")
m = 2
For i = 2 To ..End(3).Row - 1
If .Cells(i + 1, 1) <> "" And .Cells(i, 1) <> .Cells(i + 1, 1) Then
n = i
If .Range(.Cells(m, 1), .Cells(n, 1)).MergeCells Then
.Range(.Cells(m, 1), .Cells(n, 1)).UnMerge
.Range(.Cells(m, 1), .Cells(n, 1)) = .Cells(m, 1).Value
Else
.Range(.Cells(m, 1), .Cells(n, 1)).Merge
End If
m = i + 1
End If
If i = ..End(3).Row - 1 Then
If .Cells(m, 1).MergeArea.Address <> .Cells(m, 1).Address Then
.Cells(m, 1).MergeArea.Select
Selection.UnMerge
Selection = .Cells(m, 1).Value
Else
.Range(.Cells(m, 1), ..End(3)).Merge
End If
End If
Next i
End With
Application.DisplayAlerts = True
End Sub 第2题的思路实在是不满意
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
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 =
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 = : 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
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