区分値を代入して表を更新→ファイル作成を自動化

質問

エクセル2010を使用しています。
VBA（マクロ）で以下の作業を実行したいと考えていますが、
初心者につき、ご教示いただけますでしょうか。

＜前提＞
Sheet1に指示区分が6つ：B2～B7　※A列は項目名
Sheet0に計算に用いる指標：B6～B140　※6行目が項目名
Sheet2に指示区分からのデータが反映（区分とリンクを組み合わせた計算結果1）：B4～AZ138　※4行目は項目名
Sheet3に指示区分かたのデータが反映（区分とリンクを組み合わせた計算結果2）：B4～AZ138　※4行目は項目名

「Sheet1の区分のパターンを変更することでSheet2と3の内容が変わる」という仕組みがあるのですが、
1万を超える区分パターンが想定されるため、マクロやVBAを用いて 自動的に区分変更から反映データ（表）を取得したいと考えています。

Sheet4へ（A～F　※1行目は区分名）想定されるパターン区分の表を作成したので、
それを1行づつSheet1のB2～B7へ順に代入し、Sheet2と3を作成（表の更新）→別ファイルとして保存・・・
という仕組みは可能でしょうか。

ご教示いただけますと とても助かります。
よろしくお願い致します。

回答No.3

ushi2015 · ベストアンサー

こんにちは
新規ブックを作成する時に、シートは2枚以上出来ていますでしょうか？
Sub test()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim sh3 As Worksheet
　　Dim sh4 As Worksheet
　　Dim tBK As Workbook
　　Dim r As Range
　　Dim t As Range
　　Dim i As Long
　　Dim j As Long
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　Set sh3 = Worksheets("Sheet3")
　　Set sh4 = Worksheets("Sheet4")
　　Application.ScreenUpdating = False
　　j = Application.SheetsInNewWorkbook
　　Application.SheetsInNewWorkbook = 2
　　With sh4
　　　　Set t = .Range("A1").CurrentRegion.Columns(1).Cells
　　　　For Each r In t
　　　　　　If r.Row > 1 Then
　　　　　　　　sh1.Range("B2:B7").Value = _
　　　　　　　　 Application.Transpose(r.Resize(, 6).Value)
　　　　　　　　Set tBK = Workbooks.Add
　　　　　　　　sh2.Cells.Copy
　　　　　　　　tBK.Worksheets(1).Range("A1").PasteSpecial xlValues
　　　　　　　　sh3.Cells.Copy
　　　　　　　　tBK.Worksheets(2).Range("A1").PasteSpecial xlValues
　　　　　　　　tBK.SaveAs ThisWorkbook.Path & "\" & i & Format(Now(), "yyyymmdd hhmmss") & ".xlsx"
　　　　　　　　tBK.Close
　　　　　　　　i = i + 1
　　　　　　End If
　　　　　　DoEvents
　　　　Next
　　End With
　　Application.SheetsInNewWorkbook = j
　　Application.ScreenUpdating = True
End Sub
とすると、どうですか？

お礼

できています！ありがとうございます！！

j = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 2
の2行で こんなにも快適に動作するんですね！？
なるほど！シート数を先に指定してしまうんですか・・・
勉強になります！！
いつも本当にありがとうございます！！！！

回答No.2

imogasi

勤務会社の仕事上の（秘密？実は、同じようなこと（パターン）は他社でもやっている場合が多く秘密でもないのに）内容を明らかにしたくないのだろうが、
したいことの説明が抽象的になっていて、理解しにくい。たとえば「リンク」とは
なに？。俗語（コンピュターの機能の用語以外）で、リンク（関連する、とか、決まるといったような意味で気軽に）を使うな。気をまわしちゃう。
すでに回答が出ている状態で言うのも気が引けるが、
どのセルのデータがこうだから、
他シートのこういうデータを見つけて、それに対応したデータを見つけ、
こうするといった説明をすべきだろう。
1例を挙げればわかるようなことではないか。（下記例）
エクセルではＶＢＡにしろ「仕事上の！」大量の処理をやるのは無理がある場合がありえる。
データ量はどのくらいか。
これを書いてない質問が多い。量でやり方を変えざるを得ない、ものだよ。
「1万を超える・・」はその参考にならないだろう。Ｆｉｎｄ（ＶＢＡメソッド）などは，割合検索対象が１０万とかでも、検索はスムーズではないか。
どうも、データを寄せ集める（他シートから取ってくる）問題のようだ。
それはファイル結合でなされることが多く、
　　Ａ。１方のデータで他シートのＦｉｎｄを行いその行の他列のデータを取る
　　　量的に件数が多くて、この方式は耐えられないケースではないか。
　　　少数内のデータから探すなら配列に入れて、2分法・総なめ比較法で探す手もある。
　　Ｂ。両データを特定のキーでソートして、ファイルのキーのマッチングのやり方でデータを持ってくる（取る）方法を使う。
ソートの時間は、普通は事前の空き時間でやれるので、意識に入れないが
　　　毎レコードや毎行回ソートをやるような方法は不適。
　　Ｃ。ＭＳアクセスのデータとして、エクセルのデータを移し（エクスポート）、アクセ　　スの基本機能であるファイル結合でデータを取ってくる。
　これらは本件では１：ｎだろうが、（１：１、ｎ：ｎもありえる）そういうことも質問に書いてないのだが、意識しているのかな？
（例）例として、当地の郵便番号ファイルがある
　郵便番号がこの人の住所の３３０だから郵便番号ファイルを引いて市区町村名を知る。
他に市町村名の年度別人口ファイルがある。
市区町村名で人口ファイルを調べ１５年度の人口を引く。
２０万以上ならＣ、３０万以上ならＢ、それ以上ならＡのサインを入れる。
のような書き方。
ーーー
こういうのを私はロジックといっているが、このパターンはそんなに多くなく、経験者は
課題を見て、瞬時にこれを使おうと、頭に思い浮かべるようなものだ。
それを選択し間違えると、処理時間が多い、プログラム行数が多い、プログラムコードミスが増えることになる。
初心者がまず聞くべきは、どういうロジックでやるべきか、経験者から聞き、参考にして
取捨選択ができるようになることだ。
＞ご教示いただけますと
コードを書いてくれはだめ。コードを書けるだけの説明の仕方も訓練が必要と思う。

補足

説明がつたなくて気を悪くさせてしまったようで、申し訳ありません。
結果として、コードを教えていただくことになりましたが、コードを書いてくれとはお願いしたつもりはないので、ご理解いただけますと幸いです。
また、記載いただいたコードをもとに「何をするために どんなコードを使ったのか。また、どのような仕組みをとるとこのような作業に生かせるのか」を学ばせていただいておりますので、頂いたコードを「使うだけ」にとどまっているわけではないので、同じくご理解いただけますと幸いです。

とはいえ、ご指摘 ありがとうございました。

回答No.1

ushi2015

こんにちは
Sheet2、Sheet3には数式がセットされているのですよね？
とすれば、Sheet1のB2～B7へSheet4のパターン区分をセットして
Sheet2、Sheet3を別ブックとして保存するだけでいいのですよね？
Sub test()
　　Dim sh1 As Worksheet
　　Dim sh2 As Worksheet
　　Dim sh3 As Worksheet
　　Dim sh4 As Worksheet
　　Dim tBK As Workbook
　　Dim r As Range
　　Dim t As Range
　　Dim i As Long
　　Set sh1 = Worksheets("Sheet1")
　　Set sh2 = Worksheets("Sheet2")
　　Set sh3 = Worksheets("Sheet3")
　　Set sh4 = Worksheets("Sheet4")
　　Application.ScreenUpdating = False
　　With sh4
　　　　Set t = .Range("A1").CurrentRegion.Columns(1).Cells
　　　　For Each r In t
　　　　　　If r.Row > 1 Then
　　　　　　　　sh1.Range("B2:B7").Value = _
　　　　　　　　 Application.Transpose(r.Resize(, 6).Value)
　　　　　　　　Set tBK = Workbooks.Add
　　　　　　　　sh2.Cells.Copy
　　　　　　　　tBK.Worksheets(1).Range("A1").PasteSpecial xlValues
　　　　　　　　sh3.Cells.Copy
　　　　　　　　tBK.Worksheets(2).Range("A1").PasteSpecial xlValues
　　　　　　　　tBK.SaveAs ThisWorkbook.Path & "\" & i & Format(Now(), "yyyymmdd hhmmss") & ".xlsx"
　　　　　　　　tBK.Close
　　　　　　　　i = i + 1
　　　　　　End If
　　　　Next
　　End With
　　Application.ScreenUpdating = True
End Sub
1万パターンも有ったら相当時間掛かると思います。

お礼

そうですよね・・・・
でも、手作業でやるよりは早いと思うので、助かります。
いつもご親切に ありがとうございます！

補足

sh3.Cells.Copy
tBK.Worksheets(2).Range("A1").PasteSpecial xlValues
で「インデックスが有効にありません」と、止まってしまいます。
sh2の別ファイルへコピーまではできているので、
その時点でアクティブになっているファイルがsh3ではないから・・・？なんでしょうか？

初心者質問ですみません。
ご教示のほど、よろしくお願い致します。