Excel VBAで結合セルに連番を振っていくには？

質問

Microsoft Excel 2003での質問です。

表を作成しました。
結合セルが複数ある1列に（セル数はまちまち・複数の列には非結合）、連番を振っていく作業をしています。
これをVBAを使って自動化したいのです。

列に連番がすでに入力されている最終行の下のセル（つまりこれから連番が入る空白セル）を選択、
範囲指定し（セル数はまちまちなのでこれは手作業）、
セルを結合させるまではできたのですが、
この結合させたセルに、[（一つ上の結合セル）＋（１）]の値を入力させるにはどうプログラムしたらよいでしょうか？
わかりにくい説明で恐縮ですが、どなたかご教示ください。

回答No.4

ja7awu · ベストアンサー

こんな感じで如何でしょうか。

このマクロを実行すると、範囲を聞いていますので、新しく継続番号を付与する
範囲を選択して、[ＯＫ]します。指定範囲の１つ上が数字の場合は、その番号に
続く番号を付与し、数字で無い場合は、１から付与します。

複数列を含む範囲を指定した場合は、最左列だけが有効です。

Sub 結合対応連続番号付与()
Dim Num As Long
Dim Hani
On Error Resume Next
Set Hani = Application.InputBox(vbLf & "　※ 連番付与範囲を選択して" & _
　　　　"［ＯＫ］を押してください。" & vbLf & vbLf & _
　　　　"　上のセルから連続番号を付与します。（結合対応）", _
　　　　Type:=8).Resize(, 1)
If Err.Number > 0 Then Exit Sub
Hani.Resize(1).Select
If Selection.Row = 1 Then
　　Num = 1
Else
　　Selection.Offset(-1).Select
　　If IsNumeric(ActiveCell.Value) Then
　　　　Num = ActiveCell.Value + 1
　　Else
　　　　Num = 1
　　End If
End If
Hani.Resize(1).Select
Do Until Intersect(Selection, Hani) Is Nothing
　　ActiveCell.Value = Num
　　Num = Num + 1
　　Selection.Offset(1).Select
Loop
End Sub

お礼

ja7awu様

ご丁寧なご回答、ありがとうございます。
さっそく実行してみましたところ、
実にわかりやすくスムースに連番を振ることができました。
工夫次第でいろいろと応用できそうなプログラムでした。
ソースを見ても、私には分からないコマンドがたくさん出てきますが、
参考にさせていただき、勉強したいと思います。

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

回答No.3

imogasi

仮にA1:A13の例
Sub test01()
Dim cl As Range
n = 1
m = "n" '上セルはマージなし
For Each cl In Range("a1:a13")
If cl.MergeCells = True Then
If m = "y" Then
Else
cl = n
n = n + 1
End If
m = "y"
Else
m = "n"
cl = n
n = n + 1
End If
Next
End Sub

お礼

imogasi様

ご回答ありがとうございます。
記述していただいたプログラム、実行してみたのですが、私の未熟さ、無知ゆえに、ちょっと思うとおりに動いてくれませんでした。
せっかくご親切にご回答いただいたにもかかわらず、誠にふがいないお礼になってしまいますが、少し基礎を勉強し、imogasi様に教えていただいたプログラムを動かしてみようと思います。

本来であれば感激の謝辞を述べるべきですが、現在の私の腕で試行錯誤しているとお礼が遅れてしまうおそれがありますので、とりいそぎ、お礼申し上げます。

imogasi様のご厚意に添えることができず、誠に心苦しく存じます。申し訳ありません。
ありがとうございました。

回答No.2

primary5869

Sub test()
Dim m, n, a As Integer
Dim str As String
n = ActiveCell.Row
a = ActiveCell
For m = n + 1 To n + 10
Range("A" & m).Select
If ActiveCell = "" Then
a = a + 1
ActiveCell = a
End If
Next m
End Sub
'現在の選択しているところのセルの位置と値を読み込み
'その下のセルに、１加算した値を書き込む
'書き込む条件として、空白セルであること
'どこまで、連番にすればよいかわからないので
'適当

お礼

primary5869様

早速のご回答、ありがとうございます！
ご教示の通り入力したところ、希望通りの操作ができました。感謝いたします。
一つ上のセルに足したい数値は１だったので、
For文行の最後の10を１に調整し、実行してみました。

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

回答No.1

primary5869

Sub test()
Dim m, n, a As Integer
Dim str As String
For m = 1 To 20

Range("A" & m).Select
If ActiveCell = "" Then
a = a + 1
ActiveCell = a
End If
Next m
End Sub