EXCEL VBA コピーしたシートへ値をコピペ

質問

選択対象シート数は4つで、シート名は、「101」「102」「103」「104」とします。
シート名「表紙」のA列のセルはA10：101　A11：102　A12：103　A13：104となっており、
使用者はとなりのB10～B14セルに「○」「×」を入力規則から選択します。
また、シート名「表紙」のB6セルには製造番号（例：AM01-130012）を入力しておきます。
「○」となっているシートのみ選択して、下記マクロにてコピーを作成します。
コピーしたシートすべてのB2セルに製造番号を入力します。
ここまではできていて、下記のプログラムを追加したいのですが、うまくいきません。

さらに、○を付けたのと同じ行のD10～L10、D11～L11、D12～L12、D13～L13セルに、
使用者が文字列を入れる場合と入れない場合があります。文字列は左のD列から順に入れます。
文字列があれば、○を付けてコピーした対応するシートの中のH3～P3セルへ貼り付けたいのです。
D10、D11、D12、D13セルが空白のときは何も処理は行わないとします。

たとえば、下記のようにB12セルが○で、D12セルに文字列があれば、
D12～L12セルの値を、コピーで作成したシート103の中のH3～P3セルへ貼り付けたいのです。
B11セルも○ですが、D11セルに文字列がないのでシートのコピーだけ行います。
アドバイスいただけると助かります。
VBA初心者で申し訳ございませんが、よろしくお願いいたします。

＜表紙のシート＞
　　　A 　　　　B 　　　　C 　　　D 　　　 E 　　　　F 　　　G 　　　H 　 　　I 　　　　J 　 　　K 　　　 　L
5
6　　　　AM01-130012
7
8
9　
10　101　　　　×
11　102　　　　○
12　103　　　　○　　　　　　　A1-1　 A1-2　 A1-3　 A1-4 　A1-5 　A1-6 　A1-7 　A1-8 　 A1-9
13　104　　　　×

＜プログラム＞
Sub TestSample()
If Application.CountIf(Worksheets("表紙").Range("B10:B17"), "*○*") = 0 Then
MsgBox "部品番号が選択されていません。"
Exit Sub
End If

Dim 製造番号 As String
製造番号 = Range("B6").Value

Dim c As Range
Dim flg As Boolean

On Error Resume Next
flg = True
ThisWorkbook.Activate

On Error GoTo ErrOut_
For Each c In Worksheets("表紙").Range("B10:B13")
If c.Value Like "○*" Then
Worksheets(c.Offset(, -1).Text).Select flg
flg = False
End If
Next c

If Not flg Then ActiveWindow.SelectedSheets.Copy

' コピーしたすべてのシートに製造番号を書き込む
For Each 各シート In Worksheets
With 各シート
.Activate
Cells(1, 2) = 製造番号
End With
Next
Exit Sub

ErrOut_:
MsgBox """表紙""シートに記載されたシート名" & c.Offset(, -1).Text & "は存在しません。, vbInformation"
End Sub

回答No.2

cj_mover

＃１、ｃｊです。追加レスです。

> ...シートへ値をコピペ...
ということですから、
　　c.Offset(, 2).Resize(, 9).Copy Range("H3")
の部分は
　　Range("H3:P3").Value = c.Offset(, 2).Resize(, 9).Value
のように書換えた方が良いのかもしれません。
修正、お願いします。

訂正が１件。
誤）
> コピーしたシートすべてのB2セルに製造番号を入力します。
質問文では"B2"ですが、ご提示のコードでは"D2"になっています。
"B2"でお応えしています。
正）
> コピーしたシートすべてのB2セルに製造番号を入力します。
質問文では"B2"ですが、ご提示のコードでは"B1"になっています。
"B2"でお応えしています。

失礼しました。

回答No.1

cj_mover

こんにちは。

コピー元とコピー先とで、シートの対応関係を追いかけるのなら、
「纏めて複数シートをコピーする」よりも
「１シートずつコピーする」方が
簡単ですし、十分に効果的です。
ということで、設計を変えてみます。

' ' (1)
最初にシートをコピーする時は「新しいブックにコピー」
２回目からはアクティブなブックの「末尾へ...」「コピーを作成...」

' ' (2)
コピーしたすべてのシート（のB2）に製造番号を書き込む

' ' (3)
表紙シートの○に対応した行のD:L を 対応するシートのH3:P3 へ貼り付け

という流れです。

今回は、.Text プロパティで正しく文字列値をシート名に指定していますから、
存在しないシート名を指定した場合のエラー処理は省きます。

「新しいブックにコピー」した時に、コピー先のブックがアクティブに、
それぞれのシートをコピーした時に、コピー後のシートがアクティブに、
なること、を、最大限利用します。
これができるのは、標準モジュールに書いた場合だけですので、
シートモジュールやThisWorkbookモジュールに書かない様に注意してください。

アクテイブなブックが切り替わってしまっても、
コピー元を見失わないように、
　　With ThisWorkbook
　　　　・
　　　　・
　　End With
With 節を使っています。
　　　　.Worksheets
のように先頭にドット.の付いたものはすべて
　　ThisWorkbook.Worksheets
の意味です。
対して、
　　Worksheets(Worksheets.Count)
は、「新しいブックにコピー」後のアクテイブなブック＝新規に作成されたブック
のWorksheetsを指します。
また、
　　Range("B2").Value = 製造番号
　　Range("H3")
は、コピー後のシート＝アクティブなシート
のセル範囲のことです。
変数cでポイントしたセルは、
どんな時でも、ThisWorkbook.Worksheets("表紙").Range("B10:B13")の一部の単セルです。

' ' 〓〓〓　標準モジュール　専用　〓〓〓

Sub Re8376285()

　　Dim c As Range
　　Dim 製造番号 As String
　　Dim flg As Boolean

　　flg = True

' ' 親オブジェクトを明示的に！！
　　With ThisWorkbook

　　　　製造番号 = .Worksheets("表紙").Range("B6").Value

　　　　For Each c In .Worksheets("表紙").Range("B10:B13")
　　　　　　If c.Value Like "○*" Then

' ' (1)
　　　　　　　　If flg Then　　'　　初めてなら、○に対応したシートを「新しいブックにコピー」
　　　　　　　　　　.Worksheets(c.Offset(, -1).Text).Copy
　　　　　　　　　　flg = False
　　　　　　　　Else　　'　　それ以外なら、○に対応したシートをアクティブブックの最後にコピー追加
　　　　　　　　　　.Worksheets(c.Offset(, -1).Text).Copy After:=Worksheets(Worksheets.Count)
　　　　　　　　End If

' ' (2)
　　　　　　　　' ' コピーしたすべてのシート（のB2）に製造番号を書き込む
　　　　　　　　Range("B2").Value = 製造番号

' ' (3)
　　　　　　　　' ' ○の行のD:L を 対応するシートのH3:P3 へ貼り付け
　　　　　　　　If c.Offset(, 2) <> "" Then　　'　　Ｄ列が空でなければ
　　　　　　　　　　c.Offset(, 2).Resize(, 9).Copy Range("H3")
　　　　　　　　End If

　　　　　　End If
　　　　Next c

　　End With

　　If flg Then
　　　　MsgBox "部品番号が選択されていません。"
　　　　Exit Sub
　　End If

End Sub

' ' 〓〓〓　　〓〓〓

> コピーしたシートすべてのB2セルに製造番号を入力します。
質問文では"B2"ですが、ご提示のコードでは"D2"になっています。
"B2"でお応えしています。

お礼

回答ありがとうございます。
やりたいことができるようになりました。
シートをコピーする方法までアドバイスいただき勉強になりました。
質問文に誤記があり、たいへん申し訳ございませんでした。

コピー先のセルが統合されていたので、下記のようにいたしました。

　　　　　　　　' ' ○の行のD:L を 対応するシートのH3:P3 へ貼り付け
　　　　　　　　If c.Offset(, 2) <> "" Then　　'　　Ｄ列が空でなければ
　　　　　　　　　　c.Offset(, 2).Copy Range("H3")
　　　　　　　　　　c.Offset(, 3).Copy Range("I3")
　　　　　　　　　　c.Offset(, 4).Copy Range("J3")
　　　　　　　　　　c.Offset(, 5).Copy Range("K3")
　　　　　　　　　　c.Offset(, 6).Copy Range("L3")
　　　　　　　　　　c.Offset(, 7).Copy Range("M3")
　　　　　　　　　　c.Offset(, 8).Copy Range("N3")
　　　　　　　　　　c.Offset(, 9).Copy Range("O3")
　　　　　　　　　　c.Offset(, 10).Copy Range("P3")

補足

申し訳ございません。
また誤記がありました。
コピー先のセルが統合されていたので、下記のようにいたしました。

' ' ○の行のD:L を 対応するシートのH3:P3 へ貼り付け
If c.Offset(, 2) <> "" Then '　　Ｄ列が空でなければ

Range("H3").Value = c.Offset(, 2).Value
Range("I3").Value = c.Offset(, 3).Value
Range("J3").Value = c.Offset(, 4).Value
Range("K3").Value = c.Offset(, 5).Value
Range("L3").Value = c.Offset(, 6).Value
Range("M3").Value = c.Offset(, 7).Value
Range("N3").Value = c.Offset(, 8).Value
Range("O3").Value = c.Offset(, 9).Value
Range("P3").Value = c.Offset(, 10).Value