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 于 2012-4-23 23:11 编辑
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
Sub 按钮2_单击()
Dim m As Integer, n As Integer, k As Integer
Application.DisplayAlerts = False
'n = Range("a65536").End(xlUp).Row
n = ActiveSheet.UsedRange.Rows.Count
If IsNull(Range("a:a").MergeCells) = True Then
Range("a:a").UnMerge
For m = 2 To n
If Cells(m, 1) = "" Then
Cells(m, 1) = Cells(m - 1, 1)
End If
Next m
Else
k = 2
For m = 3 To n + 1
If Cells(m, 1) <> Cells(m - 1, 1) Then
Range(Cells(k, 1), Cells(m - 1, 1)).Merge
k = m
End If
Next m
End If
Application.DisplayAlerts = True
End Sub
Sub 第一题_按钮2_单击()
Dim rg As Range, r As Integer, m As Integer, n As Integer, rr As Integer
n = 3
m = Range("a65536").End(xlUp).Row
Set rg = Range("a1")
Set rg = Range("a:a").Find("A", after:=rg, MatchCase:=True, LookAt:=xlWhole, SearchDirection:=xlNext)
r = rg.Row
Do
Set rg = Range("a:a").Find("A", after:=rg, MatchCase:=True, LookAt:=xlWhole, SearchDirection:=xlNext)
rr = rg.Row
If rg.Row > r Then
Range(Cells(r, 1), Cells(rg.Row - 1, 1)).Copy Cells(1, n)
r = rr
n = n + 1
Else
Range(Cells(r, 1), Cells(m, 1)).Copy Cells(1, n)
End If
Loop Until r > rg.Row
End Sub
Option Explicit
Sub 按钮2_单击()
Dim i As Long, previous As Long
Application.DisplayAlerts = False
previous = 2
For i = 3 To 16
If (Cells(i, 1) <> "" And Cells(i, 1) <> Cells(i - 1, 1)) Or i = 16 Then
With Cells(previous, 1).Resize(i - previous)
If .MergeCells Then
.UnMerge
.FillDown
Else
.Merge
End If
End With
Debug.Print Cells(previous, 1).Resize(i - previous).Address()
previous = i
End If
Next i
Application.DisplayAlerts = True
End Sub
Sub 第一题_按钮2_单击()
Dim i As Long, j As Long, previous As Long
Dim buf
previous = 2
j = 3
For i = 3 To Cells(Rows.Count, 1).End(3).Row + 1
If Cells(i, 1) = "A" Or i = Cells(Rows.Count, 1).End(3).Row + 1 Then
buf = Cells(previous, 1).Resize(i - previous)
'Debug.Print Cells(previous, 1).Resize(i - previous).Address()
Cells(1, j).Resize(i - previous) = buf
j = j + 1
previous = i
End If
Next i
End Sub
请批改，谢谢！
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
C09:sliang28
第一题代码：Sub 第一题_按钮2_单击()
Dim a(20, 20) As String
Dim b(20, 20) As String
Dim dyg As Range
Dim i!, j!
i = 0
For Each dyg In
If dyg = "A" Then
i = i + 1
j = 0
b(i, j) = dyg
j = j + 1
Else
b(i, j) = dyg
j = j + 1
End If
Next
For i = 1 To 10
For j = 0 To 10
Sheet1.Cells(j + 1, i + 2) = b(i, j)
Next j
Next i
End Sub第二题代码：(校长，这题我不明白什么叫合并同类项，意思不理解。在我影响当中合并同类项是：比如{3A;3C;2A;2C},合并同类项变成{5A;5C},因为题意不理解，我是按照合并单元格写的，点击一下合并，再点击一下拆分)Sub 按钮2_单击()
Application.DisplayAlerts = False
Dim k, i As Integer
Dim c As Range
Dim first, last As Integer
k = 2
If Sheet2.Cells(k, 1).MergeCells Then
For Each c In
If c.MergeCells Then
c.Select
c.UnMerge
Selection.Value = c.Value
End If
Next c
Else
first = 1
For i = 1 To 20 Step 1
If Sheet2.Range("A" & i) = Sheet2.Range("A" & i + 1) Then
Else
last = i
Sheet2.Range("A" & first & ":A" & last).Select
Selection.Merge
first = i + 1
End If
Next
End If
Application.DisplayAlerts = True
End Sub
**** Hidden Message *****
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
g17:szczm121
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
第一题：
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