更に勤務割表の式を短く

質問

月間の勤務割表を作成しています。
1列3行を一枡として一人・一日の枡とし、勤務の割り振り状態を表示するものです。
列に日付、行を個人名（max16名）とし1列3行を名前の定義で15種類作成してあります。
同じシートの各セルの入力番号(2行3列を一升)でに応じて15種類を貼り付けていますが、1人-1日分は、式を短くできたのですが、16人-31日分までの式を簡単にできませんでしようか？この式を496回分作るのは、難儀ですので。

　お教えくださいませんでしょうか？勉強不足でこれが限界です。

尚名前の定義は、1行3列に1－－で勤務1・""-""で日勤・""公休""で公等にしてあります。

OS Windows7 Office2010

Sub 名前の定義の貼付け() '1人-1日分
Dim addrname_workpattern As String
addrname_workpattern = ""
With Worksheets("メイン・2")
Select Case .Range("E70").Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrname_workpattern = "日勤1"
Case 5: addrname_workpattern = "日勤2"
Case 6: addrname_workpattern = "日勤3"
Case Else
Select Case .Range("D71").Value
Case 1: addrname_workpattern = "日勤4"
Case Else
Select Case .Range("D70").Value
Case 2: addrname_workpattern = "明け"
Case 3: addrname_workpattern = "日勤"
Case 4: addrname_workpattern = "夜勤"
Case 5: addrname_workpattern = "公"
Case 6: addrname_workpattern = "有"
Case 7: addrname_workpattern = "振"
Case 8: addrname_workpattern = "特"
Case 9: addrname_workpattern = "欠"
End Select
End Select
End Select
End With
If addrname_workpattern <> "" Then
ActiveSheet.Range(addrname_workpattern).Copy
Range("D8").PasteSpecial
Application.CutCopyMode = False
End If
End Sub

Sub 名前の定義の貼付け() '16人-31日分
Dim addrname_workpattern As String
addrname_workpattern = ""
With Worksheets("メイン・2")
Select Case .Range("CQ100").Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrname_workpattern = "日勤1"
Case 5: addrname_workpattern = "日勤2"
Case 6: addrname_workpattern = "日勤3"
Case Else
Select Case .Range("CP101").Value
Case 1: addrname_workpattern = "日勤4"
Case Else
Select Case .Range("CP100").Value
Case 2: addrname_workpattern = "明け"
Case 3: addrname_workpattern = "日勤"
Case 4: addrname_workpattern = "夜勤"
Case 5: addrname_workpattern = "公"
Case 6: addrname_workpattern = "有"
Case 7: addrname_workpattern = "振"
Case 8: addrname_workpattern = "特"
Case 9: addrname_workpattern = "欠"
End Select
End Select
End Select
End With
If addrname_workpattern <> "" Then
ActiveSheet.Range(addrname_workpattern).Copy
Range("CP23").PasteSpecial
Application.CutCopyMode = False
End If
End Sub

回答No.2

nag0720 · ベストアンサー

＞ちなみに　Fox&Nextは、私も試行錯誤してやりましたが駄目でした。

どこがどうダメだったんでしょう？

全文を書くと、下記のようになります。

Sub 名前の定義の貼付け()
Dim addrname_workpattern As String
For i = 1 To 16
For j = 1 To 31
addrname_workpattern = ""
With Worksheets("メイン・2")
Select Case .Cells(70 + (i - 1) * 2, 5 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrname_workpattern = "日勤1"
Case 5: addrname_workpattern = "日勤2"
Case 6: addrname_workpattern = "日勤3"
Case Else
Select Case .Cells(71 + (i - 1) * 2, 4 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "日勤4"
Case Else
Select Case .Cells(70 + (i - 1) * 2, 4 + (j - 1) * 3).Value
Case 2: addrname_workpattern = "明け"
Case 3: addrname_workpattern = "日勤"
Case 4: addrname_workpattern = "夜勤"
Case 5: addrname_workpattern = "公"
Case 6: addrname_workpattern = "有"
Case 7: addrname_workpattern = "振"
Case 8: addrname_workpattern = "特"
Case 9: addrname_workpattern = "欠"
End Select
End Select
End Select
End With
If addrname_workpattern <> "" Then
ActiveSheet.Range(addrname_workpattern).Copy
Cells(7 + i, 4 + (j - 1) * 3).PasteSpecial
Application.CutCopyMode = False
End If
Next
Next
End Sub

お礼

ありがとうございます。若干の修正を加えて下記の式で事なきを得ました。寝ぼけていて回答の補足に返事をしてしまったにもかかわらずわざわざご丁寧に再度ご回答いただけるとは器の大きさを痛感しました。お陰様で手間が省けました。
　重ね々厚くお礼を申し上げます。

Sub 名前の定義の貼付け()

Application.ScreenUpdating = False

Dim i As Integer
Dim j As Integer
For i = 1 To 16
For j = 1 To 31
Dim addrname_workpattern As String
addrname_workpattern = ""
With Worksheets("メイン・2")
Select Case .Cells(70 + (i - 1) * 2, 6 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "勤務1"
Case 2: addrname_workpattern = "勤務2"
Case 3: addrname_workpattern = "勤務3"
Case 4: addrname_workpattern = "日勤1"
Case 5: addrname_workpattern = "日勤2"
Case 6: addrname_workpattern = "日勤3"
Case Else
Select Case .Cells(71 + (i - 1) * 2, 5 + (j - 1) * 3).Value
Case 1: addrname_workpattern = "日勤4"
Case Else
Select Case .Cells(70 + (i - 1) * 2, 5 + (j - 1) * 3).Value
Case 2: addrname_workpattern = "明け"
Case 3: addrname_workpattern = "日勤"
Case 4: addrname_workpattern = "夜勤"
Case 5: addrname_workpattern = "公"
Case 6: addrname_workpattern = "有"
Case 7: addrname_workpattern = "振"
Case 8: addrname_workpattern = "特"
Case 9: addrname_workpattern = "欠"
End Select
End Select
End Select
End With
If addrname_workpattern <> "" Then
ActiveSheet.Range(addrname_workpattern).Copy
Cells(7 + i, 5 + (j - 1) * 3).PasteSpecial
Application.CutCopyMode = False
End If
Next
Next

Application.ScreenUpdating = True

End Sub

回答No.1

nag0720

コードを書くのは面倒なので、やり方だけ。

For文を使って、16人分と31日分を繰り返す。
For i=1 to 16
For j=1 to 31
処理
Next
Next

Rangeの代わりに、Cellsを使う。
　　例えば、Rande("E70")は、Cells(70,5)と同じです。
　　1人目の1日目（i=1, j=1）なら、Cells(70+(i-1)*2,5+(j-1)*3)　とする。

補足

真夜中のお疲れのところご回答ありがとうございます。どうしてもうまくいきませんので、マクロの式全体をコピペして必要な箇所を修正して16人31日分(496回分)のマクロを作成しそのマクロを一括処理するマクロを作成しやろうかと思います。

ちなみに　Fox&Nextは、私も試行錯誤してやりましたが駄目でした。