エクセルVBA でセルの結合

質問

久しぶりに質問したいことがあります。
初歩的なVBA操作しかできない者です。
以下のようなマクロを組みたいのですがどのようにしたらよいでしょうか？
　　　　　A 　　　　　 B　　　　　　　　　C
1　　　東京
2　　　東京
3　　　京都
4　　　京都
5　　　京都
6　　　埼玉
7　　　埼玉
・　　　・
・　　　・
・　　　・

上の状態から下のようにしたい

　　　　A　　　　　　　　B　　　　　　　　C
　　--------
1
　　 東京
2
　　--------　
3
4　　京都
5　
　　--------
6
　　 埼玉
7
　　--------
・　　　・
・　　　・
・　　　・
（最終行は任意）

B列で同じ項目名のセルを結合したいです。
B列は名前順に並び替えられていて、１～１０行ぐらいで同じ項目名があり行数は共に任意です。
なおイメージ図の「------」はセル結合のイメージですので、実際には
実践で囲います。
分かりづらし説明で申し訳ありませんがよろしくお願いします。

回答No.7

ka_na_de

＃６です。

間違いがあったので、改めて投稿します。

Sub test9999()
　　Dim myLastRow As Long
　　Dim i As Long

　　myLastRow = Cells(Rows.Count, "B").End(xlUp).Row

　　Application.ScreenUpdating = False
　　For i = 1 To myLastRow
　　　　With Cells(i + 1, "B")
　　　　　　If Cells(i, "B").Value <> .Value Then
　　　　　　　　With .Borders(xlEdgeTop)
　　　　　　　　　　.LineStyle = xlContinuous
　　　　　　　　　　.Weight = xlThin
　　　　　　　　　　.ColorIndex = xlAutomatic
　　　　　　　　End With
　　　　　　Else
　　　　　　　　.Borders(xlEdgeTop).LineStyle = xlNone
　　　　　　　　.Font.ColorIndex = 2 '白
　　　　　　End If
　　　　End With
　　Next i
　　Range("B1:B" & myLastRow).BorderAround _
　　　　LineStyle:=xlContinuous, _
　　　　Weight:=xlThin, _
　　　　ColorIndex:=xlAutomatic
　　Application.ScreenUpdating = True
End Sub

お礼

お返事ありがとうございます。
わざわざ他の方と違う記述をしていただき、
また画像を添付していただきありがとうございました。

回答No.6

ka_na_de

多数の回答が出ているので、
あえて別の視点で回答します。

私はセルの結合を行うことは極力避けるようにしています。
というのも、フィルターや並べ替えといった操作上の不都合が
多いからです。

以下は、セル結合せずに同じ項目名のセルのフォントを白色に
設定する例です。

Sub test999()
　　Dim myLastRow As Long
　　Dim i As Long
　　Dim mySide As Variant

　　myLastRow = Cells(Rows.Count, "B").End(xlUp).Row

　　Application.ScreenUpdating = False
　　For i = 1 To myLastRow
　　　　If Cells(i, "B").Value <> Cells(i + 1, "B").Value Then
　　　　　　With Cells(i + 1, "B").Borders(xlEdgeTop)
　　　　　　　　.LineStyle = xlContinuous
　　　　　　　　.Weight = xlThin
　　　　　　　　.ColorIndex = xlAutomatic
　　　　　　End With
　　　　Else
　　　　　　Cells(i + 1, "B").Font.ColorIndex = 2 '白
　　　　End If
　　Next i
　　With Range("B1:B" & myLastRow)
　　　　For Each mySide In Array(xlEdgeTop, xlEdgeLeft, _
　　　　　　　　　　　　　　　　　　xlEdgeBottom, xlEdgeRight)
　　　　　　With .Borders(mySide)
　　　　　　　　.LineStyle = xlContinuous
　　　　　　　　.Weight = xlThin
　　　　　　　　.ColorIndex = xlAutomatic
　　　　　　End With
　　　　Next mySide
　　End With
　　Application.ScreenUpdating = True
End Sub

回答No.5

Wendy02

こんにちは。

>実践で囲います。
実践で囲うというのは、罫線で囲うことと解釈しました。

ご質問の中で、B列と書いてありましたので、Cells(n,2) というように、列数は2になっています。

'-------------------------------------------

Sub MergeTest1()
Dim n As Long
Dim m As Long
Dim k As Variant

　　n = 1: m = n + 1
　　'B列で比較
　　Do Until Cells(n, 2).Value = "" And Cells(m, 2).Value = ""
　　　　If Not Cells(n, 2).Value Like Cells(m, 2).Value Then
　　　　　　With Cells(n, 2).Resize(m - n)
　　　　　　Application.DisplayAlerts = False
　　　　　　　　.Merge '結合
　　　　　　Application.DisplayAlerts = True
　　　　　　　　'罫線で囲う
　　　　　　　　For Each k In Array(7, 8, 9, 10)
　　　　　　　　　　With .Borders(k)
　　　　　　　　　　　　.LineStyle = xlContinuous
　　　　　　　　　　　　.Weight = xlThin
　　　　　　　　　　　　.ColorIndex = 1　'黒
　　　　　　　　　　End With
　　　　　　　　Next
　　　　　　End With

　　　　　　n = m
　　　　Else
　　　　　　m = m + 1
　　　　End If
　　Loop
End Sub

'-------------------------------------------

回答No.4

hige_082

Sub test()
Dim i As Long
Dim ii As Long
i = 1
For ii = 1 To Range("a65536").End(xlUp).Row + 1
If Cells(i, 2).Value <> Cells(ii, 2).Value Then
Application.DisplayAlerts = False
Cells(i, 2).Resize(ii - i, 1).Merge
Application.DisplayAlerts = True
i = ii
End If
Next ii
End Sub

参考まで

お礼

ご回答ありがとうございます。
列については表示の誤りがあり失礼しました。
自分が作ろうとしたものに近いです。
勉強させていただきます。

回答No.3

kybo

下記のマクロでどうでしょうか

Sub macro()
Dim C As Range
Dim R As Range
Set R = Range("A1")
For Each C In Range("A1", Range("A" & Rows.Count).End(xlUp))
If C.Value <> C.Offset(1).Value Then
Application.DisplayAlerts = False
'セルの結合
Range(R, C).Merge
Application.DisplayAlerts = True
'罫線を引く
Range(R, C).Borders.Weight = xlThin
Set R = C.Offset(1)
End If
Next C
End Sub

お礼

早速の回答ありがとうございます。
列については表示の誤りがあり失礼しました。
なるほど、こういう記述もあるのですね。
参考にさせていただきます。

回答No.2

okormazd

#1
訂正
最後
Application.DisplayAlerts = False
↓
Application.DisplayAlerts = True

回答No.1

okormazd

質問では、A列に「東京」とか入っているが、B列に入っているのか。
A列はそのままで、B列に結合したデータを作りたいのかはっきりしない。

下記は、B列に元データが入っていて、それを結合するようになっているから、自分で意図するように修正してください。

Sub test()
Application.DisplayAlerts = False
re = Cells(65536, 2).End(xlUp).Row
For r = 1 To re
r1 = r
cl1 = Cells(r1, 2).Value
cl2 = Cells(r + 1, 2).Value
While cl1 = cl2
r = r + 1
cl2 = Cells(r + 1, 2).Value
Wend
Range(Cells(r1, 2), Cells(r, 2)).Merge
Next
Application.DisplayAlerts = False
End Sub

お礼

早速の回答ありがとうございます。
列については説明誤りがあり失礼しました。
早速試してみたいと思います。