こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

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

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

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

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

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

<sheet1=4月1日>
(B3、C3から下に)
井端早番
高橋早番
(B8、C8から下に)
坂本遅番
長野遅番

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

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

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の3行目から、リスト化する。

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の8行目から、リスト化する。

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

投稿日時 - 2016-03-12 21:30:36

QNo.9142104

暇なときに回答ください

質問者が選んだベストアンサー

一例です。

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行目の最終列-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

'早番の場合は日付シートの3行目から順に入力
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

'遅番の場合は日付シートの8行目から順に入力
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を設定していますので修正下さい。

投稿日時 - 2016-03-12 22:58:56

お礼

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

投稿日時 - 2016-03-14 18:15:50

このQ&Aは役に立ちましたか?

0人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

>日付別にsheet1に4月1日の勤務者とその出勤者の勤務を

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

 それに、

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

という事を一々、行うのは大変ですので、勤務表マスタシートに記載されている日付に該当する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

投稿日時 - 2016-03-13 03:58:49

お礼

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

投稿日時 - 2016-03-14 18:25:10

あなたにオススメの質問