マクロ 一覧からシートを作成する

質問

いつも回答して頂き、とても感謝しています。

似た様な質問を過去にしていますが、

前回の質問は、一列にシート名が記載しており、これを参照してシートを次々と挿入するマクロの作り方でしたが、今回は、複数列にシート名が記載されている場合のマクロ記述についてです。

自分なりに考えてみましたが、set = s の値がNOTHINGになり、挿入したシートに名前を記載する事ができませんでした。原因がさっぱり分からないので御教授の程宜しくお願い致します。

Sub シートの挿入()

Dim s As Worksheet
Dim r As Long
Dim c As Long
On Error GoTo errhandle

c = 2

With Worksheets("作業名一覧")
For r = 2 To .Cells(Rows.Count, c).End(xlUp).Row
Do While .Cells(r, c).Value <> ""
Set s = Worksheets(Cells(r, c).Value)
c = c + 1
Loop
Next r
End With
Exit Sub

errhandle:
Worksheets.Add after:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = Cells(r, c).Value
Worksheets(h.Value).Cells.ColumnWidth = 1
Worksheets(h.Value).Cells.RowHeight = 15
Resume

End Sub

回答No.2

keithin · ベストアンサー

sub macro2()
　dim h as range
　dim pos as long

　on error goto errhandle
　pos = worksheets("作業名一覧").index
　for each h in worksheets("作業名一覧").range("B2").currentregion
　　if h <> "" then
　　　pos = worksheets(h.value).index
　　end if
　next
　exit sub

errhandle:
　worksheets.add after:=worksheets(pos)
　activesheet.name = h.value
　cells.columnwidth = 1
　cells.rowheight = 15
　resume
end sub

お礼

さっそく貼り付けて確認してみました。
エラーも無く、思っていた通りの動作でした。Ifの位置をErrhandleの後に入れたのが間違っていたんですね。

記述を見ていて思った事ですが、
pos = worksheets(h.value).index と Set s = Worksheets(h.Value) の違いってなんなんでしょうか？

試しに、Set～で記述してみても、動作的には大差がなかったように思えるのですが。

回答No.1

keithin

sub macro1()
　dim h as range
　on error resume next
　for each h in worksheets("作業名一覧").range("B2").currentregion
　if h <> "" then
　　worksheets.add after:=worksheets(worksheets.count)
　　with activesheet
　　　.name = h.value
　　　.cells.columnwidth = 1
　　　.cells.rowheight = 15
　　end with
　end if
　next
end sub

お礼

範囲をcurrentregionで指定するだけでよかったんですね。
思いもつきませんでした。途中で空欄があっても、次々とシートが挿入されて完璧でした。

hのシートが有るか無いか確認しながらやる事を考え、下記のマクロを記述しましたが、途中空欄があった場合、エラーが発生してしまいます。

Sub シート挿入()

Dim h As Range
Dim s As Worksheet
On Error GoTo errhandle

For Each h In Worksheets("作業名一覧").Range("B2").CurrentRegion
Set s = Worksheets(h.Value)
　　　　MsgBox h.Value & "有り"

Next
Exit Sub

errhandle:
Worksheets.Add after:=Worksheets(Worksheets.Count)
With ActiveSheet
.Name = h.Value
.Cells.ColumnWidth = 1
.Cells.RowHeight = 15
End With
Resume

End Sub

また、下記のようにすると、空欄の所で永久ループに入ってしまいます。

Sub シート挿入()

Dim h As Range
Dim s As Worksheet
On Error GoTo errhandle

For Each h In Worksheets("作業名一覧").Range("B2").CurrentRegion
Set s = Worksheets(h.Value)
MsgBox h.Value & "有り"

Next
Exit Sub

errhandle:
If h <> "" Then
Worksheets.Add after:=Worksheets(Worksheets.Count)
With ActiveSheet
.Name = h.Value
.Cells.ColumnWidth = 1
.Cells.RowHeight = 15
End With
End If
Resume

End Sub

シートが有るか無いか確認しながら、シートを挿入する場合、どんな記述にしたらよろしいのでしょうか？御教授の程よろしくお願い致します。