エクセルの勤務表（マクロ）についての質問です。

質問

エクセルの勤務表から、日付別に出勤者とその出勤者の勤務を抜き出すマクロを作りたいのですが、途中で分からなくなってしまい困っています。

初めまして。私はマクロを初めてまだ、２ヶ月の初心者でございます。
質問内容に、不手際がありましたら、ご容赦ください。

勤務表マスタには勤務表があり、それ以外にsheet1 からsheet30まで、３０枚のシートを用意しておき、日付別にsheet1に４月１日の勤務者とその出勤者の勤務を（早番はB3から下に表示し、遅番はB8下に表示するようにします。）抜き出し、同じようにしてsheet2には、４月２日の勤務者とその出勤者の勤務を、同じように、それぞれB３とB８に抜き出し…というように、３０日分抜きだしたいのです。休みの人は表示しません（画像写真を参照願います。見にくい写真で恐縮でございます。）

＜勤務表マスタ＞
名前 4月1日 4月2日 4月3日 4月4日…
坂本 遅番 早番 遅番 休み…
井端 早番 休み 早番 遅番…
長野 遅番 早番 早番 早番…
阿部 遅番 遅番 遅番 早番…
村田 休み 早番 遅番 遅番…
高橋 早番 遅番 休み 遅番…

＜sheet1=４月１日＞
（B3、C3から下に）
井端 早番
高橋 早番
（B8、C8から下に）
坂本 遅番
長野 遅番

まずは、勤務表から４月１日だけをとりあえず抜き出そうと、マクロを作って、勤務表マスタから、sheet1である、４月１日には、転記できたのですが、同じように、sheet2(４月2日)、 sheet3(４月3日)…と勤務表マスタから、各シートに転記するには、どうすれば良いのか？分からなくなってしまいました。

力技で、このマクロの「Sheet1」の部分を「Sheet2」にするようにしてといった感じで、あと３０個書けば、できるような気もしますが、膨大な行数になりますし、何か他の方法をと考えたのですが、まだまだ、初心者で、どうすれば良いのか全く思いつきません。ここまで、インターネットで調べたりして、何とか作ったもので、全く幼稚なマクロかと思いますが、なにとぞ、ご鞭撻のほど、よろしくお願い致します。

Public Sub test()
Dim strSerch1 As String
Dim strSerch2 As String
Dim LastRow As Long
Dim i As Long, j As Long, k As Long

'検索する文字を以下の二つの変数に代入
strSerch1 = "早番"
strSerch2 = "遅番"

'Sheet1に「早番」の人をリスト化するための変数を設定
'最初に入れるのが3行目なのでjに3を代入
j = 3

With Worksheets("勤務表マスタ")
'.Cells(.Rows.Count, 1).End(xlUp).Rowで最後の行がどこなのか調べて
'LastRow変数に代入する。
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

For i = 2 To LastRow
'ここで2列目を検索して、「早番」の人がいたら、Sheet1の３行目から、リスト化する。

If .Cells(i, 2).Value = strSerch1 Then
Worksheets("Sheet1").Cells(j, 2).Value = .Cells(i, 1).Value
Worksheets("Sheet1").Cells(j, 3).Value = .Cells(i, 2).Value

j = j + 1

End If

Next i

End With

'Sheet1に「遅番」の人をリスト化するための変数を設定

'最初に入れるのが8行目なのでkに8を代入

k = 8

With Worksheets("勤務表マスタ")

LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

For i = 2 To LastRow

'ここで2列目を検索して、「遅番」の人がいたら、Sheet1の８行目から、リスト化する。

If .Cells(i, 2).Value = strSerch2 Then
Worksheets("Sheet1").Cells(k, 2).Value = .Cells(i, 1).Value
Worksheets("Sheet1").Cells(k, 3).Value = .Cells(i, 2).Value

k = k + 1

End If

Next i

End With

End Sub

回答No.1

dogs_cats · ベストアンサー

一例です。

Sub test()

Dim strSerch1 As String
Dim strSerch2 As String
Dim LastRow As Long
Dim i, j, k, m, n As Long
Dim Myday As Integer
Dim ws As Worksheet

'検索する文字を以下の二つの変数に代入
strSerch1 = "早番"
strSerch2 = "遅番"

'Sheet1に「早番」の人をリスト化するための変数を設定
'最初に入れるのが3行目なのでjに3を代入

With Worksheets("勤務表マスタ")

'月の最終日を取得（１行目の最終列-1が月の最終日)
Myday = .Cells(1, Columns.Count).End(xlToLeft).Column - 1

'.Cells(.Rows.Count, 1).End(xlUp).Rowで最後の行がどこなのか調べて
'LastRow変数に代入する。
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row

For i = 1 To Myday

'日付シート名を変数に格納
Set ws = Worksheets("sheet" & i)

'日付シートのB1に日付入力
ws.Range("B1") = Format(.Cells(1, i + 1), "m月d日")

j = 3
k = 8

For m = 2 To LastRow

'早番の場合は日付シートの３行目から順に入力
If .Cells(m, i + 1).Value = strSerch1 Then
ws.Cells(j, 2).Value = .Cells(m, 1).Value
ws.Cells(j, 3).Value = .Cells(m, i + 1).Value

j = j + 1

End If

'遅番の場合は日付シートの８行目から順に入力
If .Cells(m, i + 1).Value = strSerch2 Then
ws.Cells(k, 2).Value = .Cells(m, 1).Value
ws.Cells(k, 3).Value = .Cells(m, i + 1).Value

k = k + 1

End If

Next m

Next i

End With

End Sub

日付シートのデータをクリアする事を追加しています。本ブックを翌月使用すると前月データが残る為。B3~C10を設定していますので修正下さい。

お礼

返信遅くなってすいません。丁寧なご回答ありがとうございます。
自分の拙いマクロをそのまま使っていただいてありがとうございます。
書いていただくと「なるほど」と思うのですが、今の自分の実力では、全く思い浮かばず、とても参考になりました。ありがとうございました

回答No.2

kagakusuki

>日付別にsheet1に４月１日の勤務者とその出勤者の勤務を

というやり方では、どのシートに何年の何月何日のデータが転記されているのか解り難いので、例えば2016年４月１日のデータを転記するシートのシート名を例えば
2016.04.01
などといった形式のシート名にしては如何でしょうか？

　それに、

>それ以外にsheet1 からsheet30まで、３０枚のシートを用意しておき、

という事を一々、行うのは大変ですので、勤務表マスタシートに記載されている日付に該当する2016.04.01～2016.04.30などといったシート名のシートがもしも用意されていなかった場合には、その日付に該当するシート名のシートが自動的に追加される様なマクロにされては如何でしょうか？

　後それから、「勤務表マスタ」というシート名のシートがもしも存在していなかった場合や、転記すべきデータが存在しなかった場合おいても、エラーとならない様にする処置も付けた方が宜しいのではないかと思います。

Sub QNo9142104_エクセルの勤務表についての質問です()

Const MasterSheetName = "勤務表マスタ" '元のリストが存在するシートのシート名
Const DateRow = 1 '元のリストが存在するシートにおいて日付が入力されている行の行番号
Const NameColumn0 = "A" '氏名が入力されている列の列番号
Dim MasterSheet As Worksheet, mySheet As Worksheet, mySheetName As String, _
i As Long, c As Range, LastRow As Long, LastColumn As Long, _
NameColumn As Long, PasteCell(2) As String, Duty(1) As String

Duty(0) = "早番"
Duty(1) = "遅番"
PasteCell(0) = "B1" '日付の転記先のセル番号
PasteCell(1) = "B3" '早番の転記先のセル番号
PasteCell(2) = "B8" '遅番の転記先のセル番号
NameColumn = Columns(NameColumn0).Column

If IsError(Evaluate("ROW('" & MasterSheetName & "'!A1)")) Then
MsgBox "元データが入力されているシートとして設定されている" _
& vbCrLf & vbCrLf & MasterSheetName & vbCrLf & vbCrLf & _
"というシート名のシートが見つかりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "存在しないシート"
Exit Sub
End If
Set MasterSheet = Sheets(MasterSheetName)

With MasterSheet
LastRow = .Cells(Rows.Count, NameColumn).End(xlUp).Row
LastColumn = .Cells(DateRow, Columns.Count).End(xlToLeft).Column
If LastRow <= DateRow Or LastColumn <= NameColumn Then
MsgBox "処理すべきデータが見当たりません。" & vbCrLf _
& "マクロを終了します。", vbExclamation, "データ無し"
Exit Sub
End If
End With

With Application
.ScreenUpdating = False
.Calculation = xlManual
End With

For Each c In MasterSheet.Cells(DateRow, NameColumn + 1) _
.Resize(, LastColumn - NameColumn)
If IsDate(c) Then
mySheetName = Format(c.Value, "yyyy.mm.dd")
If IsError(Evaluate("ROW('" & mySheetName & "'!A1)")) Then
Sheets.Add After:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = mySheetName
End If
Set mySheet = Sheets(mySheetName)
With mySheet.Range(PasteCell(0))
.Value = c.Value
.NumberFormatLocal = c.NumberFormatLocal
End With
With MasterSheet
If c.Column > NameColumn + 1 Then _
.Range(.Columns(NameColumn + 1), _
.Columns(c.Column - 1)).Hidden = True
End With
For i = 0 To 1
With mySheet
.Range(.Range(PasteCell(i + 1)), _
.Cells.SpecialCells(xlCellTypeLastCell)).Resize(, 2).ClearContents
End With
With MasterSheet
.Range(c, .Cells(LastRow, c.Column)) _
.AutoFilter Field:=1, Criteria1:=Duty(i)
.Range(.Cells(DateRow + 1, NameColumn), .Cells(LastRow, c.Column)) _
.SpecialCells(xlCellTypeVisible).Copy mySheet.Range(PasteCell(i + 1))
End With
c.AutoFilter
Next i
MasterSheet.Columns.Hidden = False
End If
Next c

With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With

End Sub

お礼

返信遅くなってすいません。
マクロを初めて間もない私の拙いマクロにご回答下さり、ありがとうございました
今の自分の状態では「シートが自動的に追加される様なマクロ」など、思いもしませんでしたし、正直、書いてくださったマクロの後ろ半分は、よくわからないのですが、少しずつ、勉強して、このマクロの意味がわかるようになりたいという目標ができました。ありがとうございました。