【エクセル】新しいブックにコピーするVBA

質問

急ぎで必要で、困ってます。

”一覧”と”原本”という2つのシートがあります。
”一覧”シートのA55～H78には、最大24個の商品の情報が縦に入力されています。
A列はメーカー名、B列は商品名・・・H列はフラグ（”0”か”1”のどちらか）
”原本”シートは1商品1枚の注文書みたいなものです。
G13に商品名、G16にメーカー名・・・といった情報を入力する欄が設けられています。

そのエクセルに対し、以下の処理を実行してくれるVBAを作りたいです。

新しいブックを開き、そこに”原本”シートをコピーする。但し、以下の条件がある。
・”一覧”シートのH列のフラグが　”1”と入力されている商品の情報が入力されている状態の
　”原本”シートが新しいブックにコピーされる様にしたい。

例えば、”一覧”シートに、以下の情報が入力されているとします。
A55＝株式会社斎藤
B55＝鈴木チョコ
・・・
H＝1
↓
Hが1なので、G13＝鈴木チョコ、G16＝株式会社斎藤と入力されている”原本”シートを
新しいブックにコピーします。
この処理を繰り返して、H列に”1”と入力されている情報分の”原本”シートが
新しいブックにコピーされる様にしたいです。

以上、丸投げになってしまうので、大変恐縮なのですが、分かる方がいましたら返信お願いします。

回答No.3

keithin · ベストアンサー

＞シート名の設定が必要なので、”一覧”シートのB列（商品名）を
＞シート名に設定しつつ、1つの新規ブックを作成したいです。

そういう余計な細工が追加されると，途端に例えば
・間違いでＢ列会社名がダブってたらエラーになる
・間違いでＢ列会社名が無記入だとエラーになる
・Ｂ列会社名にシート名で使えない文字が含まれているとエラーになる
など，あれこれ追加で考えて具体的に手当しなきゃならない事がどんどん増えていきます。自力で対応を検討して下さい。

作成例：
sub macro1r1()
　dim w1 as worksheet
　dim wg as worksheet
　dim r as long
　dim w as workbook
　dim flg as boolean

　set w1 = worksheets("一覧")
　set wg = worksheets("原本")
　on error resume next

　for r = 55 to 78
　　if w1.cells(r, "H") = 1 then
　　’追加
　　　if flg then
　　　　wg.copy after:=w.worksheets(w.worksheets.count)
　　　else
　　　　wg.copy
　　　　set w = activeworkbook
　　　　flg = true
　　　end if
　　　activesheet.name = w1.cells(r, "B")

　　　range("G13") = w1.cells(r, "B")
　　　range("G16") = w1.cells(r, "A")
　　end if
　next r
end sub

お礼

目的のものができました。ありがとうございました。

回答No.2

mar00

Sub Macro1()
Set WS01 = Sheets("一覧")
Set WS02 = Sheets("原本")
For i = 55 To 78
If WS01.Range("H" & i) = 1 Then
WS02.Copy Before:=WS02
Sheets(Sheets.Count - 1).Name = WS01.Range("B" & i)
Range("G13") = WS01.Range("B" & i)
Range("G16") = WS01.Range("A" & i)
End If
Next i
Sheets.Select
Sheets.Copy
Application.DisplayAlerts = False
Sheets(Array("一覧", "原本")).Select
ActiveWindow.SelectedSheets.Delete
Application.DisplayAlerts = True
End Sub
という感じでいいと思います。

補足

試させて頂きましたが、不具合が発生します。

■1つ目
実行すると『インデックスが有効範囲にありません。』と出る
該当範囲＞Sheets(Array("一覧", "原本")).Select

■2つ目
シート名に（2）と付いてしまう。

■3つ目
シート名と、シートの中の情報が合わない。

回答No.1

keithin

作りたいじゃなくて作ってほしいの間違いですね。

sub macro1()
　dim w1 as worksheet
　dim wg as worksheet
　dim r as long

　set w1 = worksheets("一覧")
　set wg = worksheets("原本")

　for r = 55 to 78
　　if w1.cells(r, "H") = 1 then
　　　wg.copy
　　　range("G13") = w1.cells(r, "B")
　　　range("G16") = w1.cells(r, "A")
　　end if
　next r
end sub
みたいな。

補足

そうですよね。「作ってほしい」です。申し訳ありません。

上記のVBAでほぼOKでした。
ですが、1点だけ考えていたのと違う結果になってしまいました。

このVBAだと、フラグが”1”の個数分の新規ブックが作成されるのですが、
1つの新規ブックに、全ての商品シートを作りたいのです。
そうすると、シート名の設定が必要なので、”一覧”シートのB列（商品名）を
シート名に設定しつつ、1つの新規ブックを作成したいです。

すぐにお返事を送って頂いて大変申し訳ありません。
この1点だけ対応して頂けたら嬉しいです。