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 回答日時： 2013/12/07 09:13

＃１、ｃｊです。

追加レスです。

> ...シートへ値をコピペ...
ということですから、
　　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 回答日時： 2013/12/07 05:10

こんにちは。

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

' ' (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 '　　Ｄ列が空でなければ

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

補足日時：2013/12/08 17:58

この回答へのお礼

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

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

　　　　　　　　' ' ○の行の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")

お礼日時：2013/12/08 17:07