複数シートにまたがる連番を自動的に出したい。

質問

添付画像のようなシートが１１枚あるEXCELファイルを作りました。内容は宿泊施設のバリアフリー調査です。僕自身既存のバリアフリーマップにちょっとした使い難さを感じていて、いろんな物（サイトやマップ）を見て回っているのですが、なかなかないので自分で作ろうと思い、調査票を作っているところです。

僕は車イスユーザーですが、友人には視覚障害者も聴覚障害者も居るので、彼らのことも考えて調査票を作ったら、一気に２５０以上も調査項目が出てきてしまい、調査を進めていくうえで、まだまだ増えていきそうなのです。

そこで、連番を自動的に触れないかと思っているのですが、VBA・FUNCTIONではうまくいきませんでした。

もしかすると、function より、subの方がうまくいくかもしれませんが、良く分からないので、ご教授お願い致します。

回答No.3

HohoPapa

訂正します。

>>12行目以下に2から振り出せばいいんですね？
これを漏らしていました。

Sub PutNum()

　Dim shCount As Long
　Dim wkCntS As Long
　Dim wkCntL As Long
　Dim wkCntN As Long

　'シートの数を数える
　shCount = ThisWorkbook.Sheets.Count

　'振り出す番号を初期化
　wkCntN = 1

　'番号を振り出す
　For wkCntS = 1 To shCount
　　With ThisWorkbook.Sheets(wkCntS)
　　　For wkCntL = 12 To 80
　　　　If ((.Cells(wkCntL, 3).Value <> "") Or _
　　　　　 (.Cells(wkCntL, 4).Value <> "")) Then
　　　　　wkCntN = wkCntN + 1
　　　　　.Cells(wkCntL, 2).Value = wkCntN
　　　　Else
　　　　　.Cells(wkCntL, 2).Value = ""
　　　　End If
　　　Next wkCntL
　　End With
　Next wkCntS

End Sub

お礼

ありがとうございます。
実は縦結合のセルが後、2カラム分あるのですが、ここまで来たらあとは自力で出来ると思います。
本当に助かりました。ありがとうございました。

回答No.2

HohoPapa

12行目以下に2から振り出せばいいんですね？
マクロでは100行まで指定していますが
81行目以下が空白なら、100でも200でもＯＫです。
（マクロ上は80に直しました。）

Sub PutNum()

　Dim shCount As Long
　Dim wkCntS As Long
　Dim wkCntL As Long
　Dim wkCntN As Long

　'シートの数を数える
　shCount = ThisWorkbook.Sheets.Count

　'振り出す番号を初期化
　wkCntN = 0

　'番号を振り出す
　For wkCntS = 1 To shCount
　　With ThisWorkbook.Sheets(wkCntS)
　　　For wkCntL = 12 To 80
　　　　If ((.Cells(wkCntL, 3).Value <> "") Or _
　　　　　 (.Cells(wkCntL, 4).Value <> "")) Then
　　　　　wkCntN = wkCntN + 1
　　　　　.Cells(wkCntL, 2).Value = wkCntN
　　　　Else
　　　　　.Cells(wkCntL, 2).Value = ""
　　　　End If
　　　Next wkCntL
　　End With
　Next wkCntS

End Sub

回答No.1

HohoPapa

2行で１ブロックのようですが、
現5,6行目を6,7行目に移し、これにより
2行のブロックが偶数行目とその次行というペアーになれば
次のようなコードで対応できるのでは？と思います。

マウロがやっていることは
・それぞれのページの6行目から100行目までの偶数行を調べ
・C列、または、D列が空欄以外の時に連番をB列に書き込みます。

Sub PutNum()

　Dim shCount As Long
　Dim wkCntS As Long
　Dim wkCntL As Long
　Dim wkCntN As Long

　'シートの数を数える
　shCount = ThisWorkbook.Sheets.Count

　'振り出す番号を初期化
　wkCntN = 0

　'番号を振り出す
　For wkCntS = 1 To shCount
　　With ThisWorkbook.Sheets(wkCntS)
　　　For wkCntL = 6 To 100 Step 2
　　　　If ((.Cells(wkCntL, 3).Value <> "") Or _
　　　　　 (.Cells(wkCntL, 4).Value <> "")) Then
　　　　　wkCntN = wkCntN + 1
　　　　　.Cells(wkCntL, 2).Value = wkCntN
　　　　Else
　　　　　.Cells(wkCntL, 2).Value = ""
　　　　End If
　　　Next wkCntL
　　End With
　Next wkCntS

End Sub

もし
現5,6行目を6,7行目に移すことが困難なら

Sub PutNum()

　Dim shCount As Long
　Dim wkCntS As Long
　Dim wkCntL As Long
　Dim wkCntN As Long

　'シートの数を数える
　shCount = ThisWorkbook.Sheets.Count

　'振り出す番号を初期化
　wkCntN = 0

　'番号を振り出す
　For wkCntS = 1 To shCount
　　With ThisWorkbook.Sheets(wkCntS)
　　　For wkCntL = 5 To 100
　　　　If ((.Cells(wkCntL, 3).Value <> "") Or _
　　　　　 (.Cells(wkCntL, 4).Value <> "")) Then
　　　　　wkCntN = wkCntN + 1
　　　　　.Cells(wkCntL, 2).Value = wkCntN
　　　　Else
　　　　　.Cells(wkCntL, 2).Value = ""
　　　　End If
　　　Next wkCntL
　　End With
　Next wkCntS

End Sub

でも大丈夫と思います。

補足

ありがとうございます。

すみません。説明が不十分でした。各シート、１～１１行目は共通しているのです。ですので、実質番号は１２行目～８０（８１）行目までなのです。
なぜ、８０行目までなのか。Ａ４にギリギリ入れられると思うからです。

右セルの空白判定はセルの縦結合もあるため、ああ言ったものにしています。

よろしくお願い致します。