エクセルマクロでセルの結合をしたい
エクセル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
お礼
大変助かりました！ ありがとうございました！！