マクロで隣接する上下のセルを比較後、処理をするには

質問

よろしくお願いします。
Excel2007です。

A1からA5000までデータが入っています。
データは文字列です。

その文字列を上から順に比較していき、
隣接する上下のデータが一致した場合、
さらにその下が一致しているかを調べ、
その作業を一致しなくなるまで続けます。

最後に、一致した部分すべてを選択し、
セルをまとめて結合し、左寄せしたいのです。

まとめて結合し、左寄せ、という部分は、
マクロを記録し、以下のようにするのはわかったのですが、

Range("a4123:a4131").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Merge
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
End With

そして、これをa5000(データが格納されている最後のセル）まで
続けたいのです。

例えば、
A1とA2を比較し、一致しないなら、A2とA3を比較。
一致したら、さらにA2とA4が一緒かどうか比較。
一致が無くなるまで続けて、最後に処理。
という感じです。

前半の部分が全くわかりません。

ご教示願えませんでしょうか。よろしくお願いします。

回答No.1

fujillin · ベストアンサー

こんな感じ？　（とりあえず100行に設定してあります）

結合後のセルの設定は、左寄せと、縦の中央表示しかしていませんので、必要なら付け加えてください。
また、空白セルが連続していても結合されます。（同じ内容の連続だから）
空白セルは例外とする場合は、セルの値が空白だったら次のセルに行くようにすれば良いです。

Sub test()
Dim rw As Long, tmp As Long
Dim str As String, flg As Boolean
Const rwEnd = 100 '//最終行

rw = 1
While (rw < rwEnd)
　str = Cells(rw, 1).Text '//対象セルの値（文字列）
　flg = False
　For tmp = rw + 1 To rwEnd
　　If Cells(tmp, 1).Text = str Then flg = True Else Exit For
　Next tmp

　If flg Then
　　Application.DisplayAlerts = False '//結合時の警告表示をキャンセル
　　Range(Cells(rw, 1), Cells(tmp - 1, 1)).Merge
　　Application.DisplayAlerts = True
　　Cells(rw, 1).HorizontalAlignment = xlLeft '//書式設定（左寄せ）
　　Cells(rw, 1).VerticalAlignment = xlCenter
　　rw = tmp '//次の行までスキップ
　Else
　　rw = rw + 1
　End If
Wend
End Sub

お礼

ありがとうございました。とても勉強になりました。
助かりました。

回答No.5

merlionXX

いろんなやり方がありますね。
参考までに

Sub test01()
Dim MyUn As Range
Dim i As Long
For i = 2 To 5000
If Cells(i, "A") <> "" And Cells(i, "A") = Cells(i - 1, "A") Then
If MyUn Is Nothing Then
Set MyUn = Union(Cells(i, "A"), Cells(i - 1, "A"))
Else
Set MyUn = Union(MyUn, Cells(i, "A"))
End If
Else
If Not MyUn Is Nothing Then
With MyUn
Application.DisplayAlerts = False
.MergeCells = True
Application.DisplayAlerts = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
Set MyUn = Nothing
End If
End If
Next i
End Sub

A5000までの途中で空白があってもかまいません。空白セル同士は結合させません。

お礼

ありがとうございます。
無事にできました。助かりました。

回答No.4

web2525

Sub test()
Application.DisplayAlerts = False
Range("A1").Activate
While ActiveCell <> ""
i = 1
While ActiveCell = ActiveCell.Offset(i)
i = i + 1
Wend
With ActiveCell
.HorizontalAlignment = xlLeft
.Resize(i).MergeCells = True
End With
ActiveCell.Offset(1).Activate
Wend
Application.DisplayAlerts = True
End Sub
こんな感じ

お礼

ありがとうございます。
助かりました。

回答No.3

hige_082

一例です

Sub test()
Dim i As Long, ii As Long
i = 1
ii = 1
Application.DisplayAlerts = False
Do Until Cells(i, 1).Value = ""
ii = ii + 1
If Not Cells(i, 1).Value = Cells(ii, 1).Value Then
Range(Cells(i, 1), Cells(ii - 1, 1)).MergeCells = True
i = ii
End If
Loop
Application.DisplayAlerts = True
End Sub

Ａ列、連続でデータがあること
空白がある場合、そこで終わり

補足

ありがとうございました。
助かりました。

回答No.2

o_chi_chi

説明のとおり作成すれば以下のようになります。
---
Sub mCheck()
i = 1 '開始
Do Until Trim$(Cells(i, 1).Value) = "" '最後のセルまで
j = i + 1
Do Until Cells(i, 1).Value <> Cells(j, 1).Value '一致しなくなるまで比較
j = j + 1
Loop
If j > i + 1 Then '一致した場合
Call 結合処理
End If
i = j
Loop
End Sub

お礼

ありがとうございます。
色々と勉強になりました。