2つのvbaを統合したい

質問

はじめまして、vba初心者のものです。
よろしくお願いします。

以前こちらに質問させて頂いたことがあります。
その以前質問して回答して頂いた2つのソースを一つに統合したいです。

1、参照元ブックと貼り付けブックの2つが存在します。
2、参照元ブックの名前の指定する必要はあると思いますが、
貼り付け先ブックは新規作成にしたいです。
3、「▼質問タイトル：vba ブック間でシート名のコピーをするには」の動作は、
貼り付け先ブックの各シートに反映されるようにしたいです。

何卒よろしくお願いします。

「▼質問タイトル：vba ブック間でシート名のコピーをするには」
http://okwave.jp/qa/q8727280.html

sub macro1()
　dim wb1 as workbook
　dim w2 as worksheet
　dim i as long

’２つのブックは既に開いている事
　set wb1 = workbooks("オリジナルブック.xlsm")　’拡張子まで正しく指定する事
　set w2 = workbooks("貼り付け先ブック.xlsx").worksheets(1)　’同上

’準備
　w2.range("A:A").clearcontents
　w2.range("A:A").numberformat = "@"
　w2.range("A1") = "シート名一覧"

’転記
　for i = 1 to wb1.worksheets.count
　if wb1.worksheets(i).name = "Sheet1" then exit for
　w2.range("A65536").end(xlup).offset(1) = wb1.worksheets(i).name
　next
end sub

「▼質問タイトル：セルの項目をシート名にしたい」
http://okwave.jp/qa/q8727637.html

sub macro1()
　dim h as range
　dim s as long, i as long
　s = worksheets.count + 1

’シートを作る
　for each h in range("C3:B" & range("C65536").end(xlup).row)
　worksheets.add after:=worksheets(worksheets.count)
　activesheet.name = h.value
　next

’別のブックにする
　for i = worksheets.count to s step -1
　worksheets(i).select false
　next i
　activewindow.selectedsheets.move
end sub

回答No.2

eden3616

出来るだけご提示のコードを崩さないようにしたつもりですが、
余計な処理を排除するため、配列を使用しています。

A列に書き出し、C列から読み取る以下の処理が不明ですので、
>w2.range("A65536").end(xlup).offset(1) = wb1.worksheets(i).name
>for each h in range("C3:C" & range("C65536").end(xlup).row)
書き出し列をC列として処理を行っています。

保存先のフォルダが不明なため、名前を付けて保存ダイアログを表示して終了するようにしています。

■VBAコード

Sub macro3()
'宣言
Dim wb(1) As Workbook
Dim h As Object
Dim i As Long
Dim mySt() As String
Dim fname As String
'wb(0)に指定するブックは開いている必要があります。
Set wb(0) = Workbooks("オリジナルブック.xlsm")
'新規ブックを作成
Set wb(1) = Workbooks.Add
'シート名を配列に格納
ReDim mySt(wb(0).Worksheets.Count, 0)
For i = 1 To wb(0).Worksheets.Count
　　If wb(0).Worksheets(i).Name = "Sheet1" Then Exit For
　　mySt(i - 1, 0) = wb(0).Worksheets(i).Name
Next i
'配列毎の処理
For i = 0 To UBound(mySt, 1) - 1
　　If mySt(i, 0) = "" Then Exit For
　　wb(1).Worksheets.Add after:=wb(1).Worksheets(wb(1).Worksheets.Count)
　　With ActiveSheet
　　　　.Name = mySt(i, 0)
　　　　.Range(.Cells(3, "C"), .Cells(3 + UBound(mySt) - 1, "C")) = mySt
　　End With
Next i
'不要な初期シート(Sheet1～3)を削除
Application.DisplayAlerts = False
wb(1).Worksheets(Array(1, 2, 3)).Delete
Application.DisplayAlerts = True
'名前を付けて保存
fname = Application.GetSaveAsFilename( _
　　InitialFileName:="貼り付け先ブック.xlsx", _
　　FileFilter:="Excelファイル, *.xlsx")
If fname <> "False" Then wb(1).SaveAs fname
End Sub

お礼

ありがとうございます。

ただ、まことに申し訳ございません。
私の伝え間違いがありました。前回ご指摘いただいているのに申し訳ございません。

参照元ブックの各シートを張り付け先ブックの各シート内のセルにシート一覧するのは、
理想としてた動作でした。

しかし参照元ブックのシート１にあるC3から始まるC列にある、
項目を各シートの名前にしたいです。
セルB列のセルの中身がnullになれば終了という動作にしたいです。

例えば。
セルB3に「山田」という文字列があれば、Sheet1は山田にする。
セルB4に「佐藤」という文字列があれば、Sheet2は佐藤にする。
例、
１、ブック１のSheet1に文字列の「山田」や「佐藤」のセルがあります。
２、ブック２は新規ブックです。

３、ブック１の最初のセルC3の文字列「山田」を、ブック２のSheet1を「山田」という名前のシート名にします。
４、ブック１の次のセルC4の文字列「佐藤」を、ブック２のSheet2を「佐藤」という名前のシート名にします。
５、ブック１の次のセルC5、C6、C7と繰り返していき文字列がなくなるまで続けます。

ご回答頂いたのに私の勉強不足のために二度手間になり申し訳ありません。

何とぞよろしくお願い申し上げます。

回答No.1

eden3616

3点確認したい事柄があります。

(1)
オリジナルブック.xlsmのシート名（シート構成）を新規で作ったブックに反映し、名前を「貼り付け先ブック.xlsx」として保存したいという事でしょうか？

(2)
シート名一覧を作成し、書き出す必要はなく直接シート名を設定出来ますが・・・
set w2 = workbooks("貼り付け先ブック.xlsx").worksheets(1)
w2.range("A1") = "シート名一覧"
w2.range("A65536").end(xlup).offset(1) = wb1.worksheets(i).name
上記の貼り付け先ブック.xlsxの1つ目のシートのセルA2以降に出力されるシート名一覧は必要なのでしょうか？

(3)
for each h in range("C3:B" & range("C65536").end(xlup).row)
ご提示のコードではC3：B末尾を範囲としていますが、
URLのコードではB3～B末尾までのセルを対象としています。
A列に一覧を書き出し、BまたはC列を取得する意図が不明です。
（おそらくA列に書き出し、A列から取得したいのだとは思いますが）
質問の際は、辻褄がせめて合うようにご提示願います。

補足

ご連絡ありがとうございます。
インラインにて失礼します。

＞(1)
＞オリジナルブック.xlsmのシート名（シート構成）を新規で作ったブックに反映し、名前を「貼り付け先ブック.xlsx」として保存したいという事でしょうか？

→はい、その通りです。

＞(2)
＞上記の貼り付け先ブック.xlsxの1つ目のシートのセルA2以降に出力されるシート名一覧は必要なのでしょうか？

→はい、必要です。
　また「▼質問タイトル：セルの項目をシート名にしたい」する際、各シートでシート名一覧が必要です。

＞(3)
＞for each h in range("C3:B" & range("C65536").end(xlup).row)
＞ご提示のコードではC3：B末尾を範囲としていますが、
＞URLのコードではB3～B末尾までのセルを対象としています。
＞A列に一覧を書き出し、BまたはC列を取得する意図が不明です。
＞（おそらくA列に書き出し、A列から取得したいのだとは思いますが）
＞質問の際は、辻褄がせめて合うようにご提示願います。

→ご指摘ありがとうございます。
　訂正がございます。
　正しくは、
　for each h in range("C3:C" & range("C65536").end(xlup).row)
　です。

何卒、宜しくお願い申し上げます。