エクセルマクロでセルの結合をしたい

質問

エクセル2003です。

E列の値は昇順で並んでいます。
先頭E3行から下の行の値と比較し
同じ値の場合はセルを結合し
値が違う場合は結合しないで次の行を比較という処理を
最終行まで行いたいです。
（添付画像参照）

例えば
E3-AA
E4-BB
E5-BB
E6-CC
E7-DD
E8-EE
E9-EE
E10-EE
E11-FF

セルE4とE5を結合します
セルE8とE9とE10を結合します。

次に結合した行と同じ行数のF列を結合します。
さらに結合した行と同じ行数のG列を結合します。

上記の場合
セルF4とF5を結合、
セルF8とF9とF10を結合します。

セルG4とG5を結合、
セルG8とG9とG10を結合します。

さらに結合した行と同じ行数のA列を結合します。
上記の場合
セルA4とA5を結合、
セルA8とA9とA10を結合します。

さらに結合したA列に数字を入力します
A4とA5を結合したA4、A5セルには
2行を結合したので２と入力
セルA8とA9とA10を結合したA8、A9、A10セルには
3行を結合したので３と入力。

とりあえず、E列の結合を完成させてそのE列を
3行目から最終行までコピーして、
「形式を選択して貼付」の「書式」で
書式のみをF,G,A列にコピーすれば出来るのではと
以下の構文を作成しました。

セルの結合時は結合するセルの先頭の行の値が結合済セルの値に
なるので最初にE列を結合していく時に
A列に結合回数を記入しようと考えました。
ただ2行の結合は、A列に2と入力されたのですが
3行連結した時も２と入力されてしまったので改造しました。
テストデータでは期待しているようになったのですが
本番データでは結合される行が4行、5行等それ以上の行数が
結合する場合が有りこの構文ではなるべくしてなっているのですが
４行以上の行結合はA列の値はいずれも３になってしまいます。
（添付画像参照）

どう修正すればいいか手段が考え付きません。
どのような方法がありますでしょうか？
よろしくお願いします。

Sub セル結合2()

'2013年10月25日

Dim 最終行 As Integer
Dim 処理行 As Integer
Dim 比較行 As Integer
Dim 確認値 As Variant
Dim 比較値 As Variant
Dim 結合回数
Dim 戻行

Application.ScreenUpdating = False
ThisWorkbook.Sheets("Sheet1").Select
最終行 = Cells(Rows.Count, 5).End(xlUp).Row 'F列の最終行を求めます。
Application.DisplayAlerts = False
For 処理行 = 3 To 最終行 '3行目から最終行の前まで繰り返します。
比較行 = 処理行 + 1 '処理行の一つ下の行と比較します。→比較行とします。
確認値 = Cells(処理行, 5).MergeArea(1, 1).Value
'チェックする値を、確認値に代入します。
比較値 = Cells(比較行, 5) '比較する値を、比較値に代入します。
If 確認値 = 比較値 Then '値が同じかどうか
Range(Cells(比較行, 5), Cells(処理行, 5)).MergeCells = True
結合回数 = Cells(処理行, 1) + 1 'セルを結合した回数
戻行 = 処理行 - 1 '処理行の1行上の行数を戻行とする
Cells(処理行, 1) = 結合回数 '処理行のA列に結合回数を記入
Cells(比較行, 1) = 結合回数 '比較理行のA列に結合回数を記入
If Cells(処理行, 1) >= 3 Then 'もしも処理行のA列が3以上の場合
Cells(戻行, 1) = 結合回数 '戻り行のA列に結合回数をセット
End If '同じでない場合は以下へ
End If '同じでない場合は以下へ
Next 処理行
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range(Cells(3, 5), Cells(最終行, 5)).Copy
Range(Cells(3, 6), Cells(最終行, 6)).PasteSpecial Paste:=xlPasteFormats
Range(Cells(3, 7), Cells(最終行, 7)).PasteSpecial Paste:=xlPasteFormats
Range(Cells(3, 1), Cells(最終行, 1)).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
MsgBox "終了しました"
End Sub

回答No.1

cj_mover · ベストアンサー

ポイント
　　Range("(A:A,E:E,F:F,G:G) 4:5").Merge
という記述で、
　　A4:A5　E4:E5　F4:F5　G4:G5
の４領域を一息にマージできます。
これを実際のコードでは
　　Range("(A:A,E:E,F:F,G:G) " & 比較行 & ":" & 処理行 - 1).Merge
のように記しています。

確認値 = 比較値、を切っ掛けにするのではなくて
確認値 <> 比較値、の時に、処理行 と 比較行 の差が２以上なら、
マージします。
（そして、既に同じ大きさのマージが済んでいれば不要なので、
　マージエリアの行数が処理行と比較行差と異なる場合だけ）

　　For 処理行 = 3 To 最終行 + 1
１行余計にループするのは最終行を含むマージを実行するのは
処理行 = 最終行 + 1、のタイミングになるからです。

E3がもし空セルだと、E2:E3を基準にマージしてしまいます。
それを避けたいならば、ループの直前の行で、
比較値を、E3とは確実に異なる値に設定しておきます。
　　比較値 = Cells(3, 5) & "開始値"
とか
　　比較値 = "Hoge"
とか。

説明コメントについては、すみませんが、語調を合わせて書くのも失礼かと思うので
殆ど書いていません。

動作は確認しましたが、厳しく検証した訳ではないので、
何か不足がある場合や、望みと異なる場合は、補足してみてください。

Sub セル結合8327309()
　　Dim 最終行 As Integer
　　Dim 処理行 As Integer
　　Dim 比較行 As Integer
　　Dim 確認値 As Variant
　　Dim 比較値 As Variant
'　　Dim 結合回数
'　　Dim 戻行

　　Application.ScreenUpdating = False
　　Application.DisplayAlerts = False
　　ThisWorkbook.Sheets("Sheet1").Select

　　最終行 = Cells(Rows.Count, 5).End(xlUp).Row 'E列の最終行を求めます。
　　比較行 = 2 ' 比較行の初期値を（ループ開始行 - 1 に）設定

　　For 処理行 = 3 To 最終行 + 1 '3行目から最終行の次まで繰り返します。
'　　　　'チェックする値を、確認値に代入します。
　　　　確認値 = Cells(処理行, 5).MergeArea(1, 1).Value

　　　　If 確認値 <> 比較値 Then
　　　　　　If 処理行 - 比較行 > 1 Then
　　　　　　　　If Cells(比較行, 5).MergeArea.Count <> 処理行 - 比較行 Then
　　　　　　　　　　Range("(A:A,E:E,F:F,G:G) " & 比較行 & ":" & 処理行 - 1).Merge
　　　　　　　　End If
　　　　　　　　Cells(比較行, 1) = 処理行 - 比較行
　　　　　　End If
　　　　　　比較行 = 処理行
　　　　　　比較値 = 確認値 '比較する値を、比較値に代入します。
　　　　End If
　　Next 処理行

　　Application.DisplayAlerts = True
　　Application.ScreenUpdating = True
　　MsgBox "終了しました"
End Sub

お礼

返事がおくれました。
ありがとうございます。
すでにこの回答を利用して
運用hしております。

回答No.2

kagakusuki

回答No.1様の方法以外にも、次の様な方法も御座います。

Sub Macro()

Dim I As Long '繰り返し処理用の変数
Dim H As Long 'E列において同じ値が連続している回数
Dim LR As Long '最終行
'最終行を求める際に、「End(xlUp).Row」を用いますと、関数等で空欄になっているセルの行番号や、現在は空欄でも過去においてデータが入っていた事のあるセルの行番号等の、本当の最終行よりも下の行の行番号を求めてしまう場合があるため、次の方法を用います。
LR = Application.Evaluate("MAX(IF(COUNT(E3:INDEX(E:E,ROWS(E:E))),MATCH(9E+307,E:E),0),IF(COUNTIF(E3:INDEX(E:E,ROWS(E:E)),""*?""),MATCH(""*?"",E:E,-1),0))")
If LR = 0 Then Exit Sub
Application.DisplayAlerts = False
For I = 3 To LR
H = 0
Do
H = H + 1
Loop While Range("E" & I + H) = Range("E" & I)
Range("A" & I).Resize(H, 1).Merge
Range("E" & I).Resize(H, 1).Merge
Range("F" & I).Resize(H, 1).Merge
Range("G" & I).Resize(H, 1).Merge
Range("A" & I).Value = H
I = I + H - 1
Next I
Application.DisplayAlerts = True

End Sub

お礼

返事が遅れました。
ありがとうございます。