月間の勤務割表を作成しています。 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
↧