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

Question

よろしくお願いします。
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が一緒かどうか比較。
一致が無くなるまで続けて、最後に処理。
という感じです。

前半の部分が全くわかりません。

ご教示願えませんでしょうか。よろしくお願いします。

fujillin · Accepted Answer

こんな感じ？　（とりあえず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

merlionXX · Answer

いろんなやり方がありますね。
参考までに

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までの途中で空白があってもかまいません。空白セル同士は結合させません。

web2525 · Answer

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
こんな感じ

hige_082 · Answer

一例です

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

Ａ列、連続でデータがあること
空白がある場合、そこで終わり

o_chi_chi · Answer

説明のとおり作成すれば以下のようになります。
---
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

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

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

いろんなやり方がありますね。

Sub test()

一例です

この回答への補足

説明のとおり作成すれば以下のようになります。

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

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