EXCEL VBA コピーした複数シートを編集する

質問

選択対象シート数は4つで、シート名は、「101」「102」「103追加工」「104」とします。
シート名「表紙」のセルはA1：101　A2：102　A3：103追加工　A4：104となっており、
使用者はB1～B4セルに「○」「×」を入力規則から選択します。
予めシート名「表紙」のB6セルには製造番号（例：AM01-130012）を入力しておきます。
「○」となっているシートのみ選択して、下記マクロにてコピーを作成します。
コピーしたシートすべてのB2セルに製造番号入力します。
作製したコピーを１つ上のフォルダに名前を付けて保存します。
ここまでは、できているのですが下記で行き詰っています。

さらに、○を付けた右よこのC1～C4セルに数値1～9を入力しておき、
○を付けてコピーで作成した対応するシートの中を、
この数値によって編集するプログラムを追加したいのですが、うまくいきません。
アドバイスいただけると助かります。
VBA初心者で申し訳ございません。

どのような編集を行うのかが情報として必要でしたら下記になります。
101、102、103追加工、104それぞれのシートのD3セルに#1、E3セルに#2、・・・、L3セルに#9
（#1～#9）が予め入っています。
C1～C4セルは1～9の数値を入力規則で選択します。
たとえば、B1セルとB4セルを○に、C1セルを2、C4セルを8にして実行した場合、
コピーしたシート101のF3～L3セルをクリア（#1と#2を残して空白）に、
コピーしたシート101のL3セルをクリア（#1～#8を残して空白）にしたいのです。
もし、C1～C4セルで選択した値が9のときは編集する必要がありません。

Sub シートを選択してコピーを作成する()
If Application.CountIf(Worksheets("表紙").Range("B1:B4"), "*○*") = 0 Then
MsgBox "部品番号が選択されていません。"
Exit Sub
End If

Dim 製番 As String
製番 = Range("B6").Value
'(xlRangeValueDefault)

sFileFullPath = ThisWorkbook.Path
'-------------------------------------------------
' 1つ上の階層のフォルダのまでのフルパスを取得
'-------------------------------------------------
For i = Len(sFileFullPath) To 0 Step -1
If InStr(i, sFileFullPath, "\") > 0 Then
'現在のフォルダ名を取得
sFolderName = Mid(sFileFullPath, InStr(i, sFileFullPath, "\") + 1)
'1つ上の階層のフォルダのまでのフルパスを取得
sParentFolderPath = Mid(sFileFullPath, 1, InStr(1, sFileFullPath, sFolderName) - 2)
Exit For
End If
Next

Dim ans As Integer
If Dir(sParentFolderPath & "\" & (製番) & "_寸法検査成績書" & ".xls") <> "" Then
ans = MsgBox(sParentFolderPath & "に [" & 製番 & "_寸法検査成績書" & ".xls" & "] が既に存在します。" & vbLf & "上書きしますか？", vbYesNo, "上書きの確認")
If ans = vbYes Then
Kill (sParentFolderPath & "\" & (製番) & "_寸法検査成績書" & ".xls")
Else
MsgBox "マクロを終了します。"
Exit Sub
End If
End If

'-------------------------------------------------
' 選択したシートのコピーを作成する
'-------------------------------------------------
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("B1:B4")
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

ActiveWorkbook.SaveAs sParentFolderPath & "\" & 製番 & "_寸法検査成績書" & ".xls", xlWorkbookNormal
ActiveWorkbook.Close SaveChanges:=False

' 元のシートに戻る
Worksheets("表紙").Select
MsgBox sParentFolderPath & "に [" & 製番 & "_寸法検査成績書" & ".xls" & "] を作成しました。"

Exit Sub

ErrOut_:
MsgBox """表紙""シートに記載されたシート名" & c.Offset(, -1).Text & "は存在しません。" & _
vbLf & "全角半角の相違を含め、シート名を確認してください。", vbInformation

End Sub

回答No.1

keithin · ベストアンサー

各シートの名前に応じてＣ１からＣ４セルを調べ、＃１から＃９のどれが記入してあるか確認して所定の仕事をするだけ、と思いますが。

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

select case thiswokbook.worksheets("表紙").cells(application.match(各シート.name, array("101", "102", "103追加工", "104"), 0), "C").value

case "#1"
’＃１の仕事をする

case "#2"
’＃２の仕事をする
’：
case "#9"
’do nothing

case else
’不適切な記入内容

end select

End With
Next

お礼

早々に回答いただき、ありがとうございます。感謝いたします。
動作の確認をいたしました。
C1～C4セルの値は1～9なので、case "#1"　→　case "1"でよいのですね？
質問のとおり、A1～A4にシート名、B1～B4に○×、C1～C4に1～9では動作しますが、
データの行を変更して、A10～A13にシート名、B10～B13に○×、C10～C13に1～9とすると、
case "1"～の処理がされず、どこを修正すればよいのか悩んでいます。
ご教授いただけると幸いです。
初歩的な質問であるとは思いますが、よろしくお願い申し上げます。
ちなみに下記のように記述しております。

Case "1"
Range("E3:L3").Select
Selection.ClearContents

Case "2"
Range("F3:L3").Select
Selection.ClearContents
：

回答No.2

keithin

＞C10～C13に1～9とすると、

１０１や１０４に応じて、正しくＣ１０からＣ１３を取りに行かせなきゃダメです。

select case thiswokbook.worksheets("表紙").cells(application.match(各シート.name, array("101", "102", "103追加工", "104"), 0)+9, "C").value

＞C1～C4セルの値は1～9なので、case "#1"　→　case "1"でよいのですね？

「#1」だったハズですが？
まぁそれでも動きますが、
case 1
の方が安心です。

お礼

ありがとうございます。
たいへん勉強になりました。
努力して理解を深めていたいと思います。