シート名と一致、他複数も一致したら

投稿者 : ドカベン     投稿日時 : 2025/04/19(Sat) 22:22:44     OS : 未指定     EXCEL : 未指定

---

転記元bookのシート名（社員名）と、転記先bookの出勤簿シートのD列の社員名が一致するか確認し、一致したら→
転記元bookのA列（日付）と転記先bookのA列（日付）、転記元bookのD列（部署）と転記先bookのC列（部署）の一致を確認し、一致したら→
転記元bookのF列（出勤）とG列（退勤）を、転記先bookのE列（出勤）とF列（退勤）に転記する→
転記元bookの最終シート（最後の社員名まで）まで繰り返す。


転記元book：https://ibb.co/v687zBwk
転記先book：https://ibb.co/YngmPh9

唐突に申し訳ありませんが、
どなたかこのようなことを行えるマクロを教えていただけませんか？
何卒よろしくお願い申し上げます。

投稿者 : てらてら     投稿日時 : 2025/04/20(Sun) 05:53:13

---

こんにちは。
参考にしてみてください。
日付の所は日付型にしないと動かないのでヨロシク。

'転記先Book標準モジュールに書きます。
Sub macro()
    Dim i As Long, j As Long
    
    Dim 日付 As Date
    Dim 社員名 As String
    Dim 部署 As String
    
    Dim 転記元book As Workbook
    Dim mSh As Worksheet    '転記元シート
    Dim mLastRow As Long
    
    
    Set 転記元book = Workbooks("転記元book.xlsm") 'ブックは開いておく
    
    Dim sh As Worksheet
    Set sh = ThisWorkbook.Worksheets("出勤簿")
    Dim lrow As Long
    lrow = sh.Cells(Rows.Count, 1).End(xlUp).Row
    
    For Each mSh In 転記元book.Worksheets
        mLastRow = mSh.Cells(Rows.Count, 1).End(xlUp).Row
        社員名 = mSh.Name
        For i = 2 To mLastRow
            日付 = mSh.Cells(i, "A")
            部署 = mSh.Cells(i, "D")
            
            For j = 2 To lrow
                If sh.Cells(j, "A") = 日付 And _
                    sh.Cells(j, "C") = 部署 And _
                    sh.Cells(j, "D") = 社員名 Then
                    
                    mSh.Cells(i, "F").Copy sh.Cells(j, "E")
                    mSh.Cells(i, "G").Copy sh.Cells(j, "F")
                    Exit For
                End If
            Next j
        Next i
    Next mSh

End Sub

投稿者 : ピロリ     投稿日時 : 2025/04/20(Sun) 18:45:38

---

下は、転記先の社員の出退勤時刻を、転記元の該当社員シートから抽出するって感じの処理です。
転記元のシートを繰り返すって訳ではないですが、こんな感じでも出来るってサンプルです。ご参考まで。
ちなみに、転記元ブックは「転記元book.xlsx」で開いている状態。　各々の日付（03/01(土)や、1日）は
日付型の同データ（2025/3/1）の前提です。
画像の転記先シートの例が 4月っぽいので気になりました･･･

Sub Sample()
    Dim 転記元 As Worksheet, 転記先 As Worksheet
    Dim エラー As String, 社員 As String, i As Long, j As Long
    
    Set 転記先 = ThisWorkbook.Worksheets("出勤簿")
    エラー = ""
    For i = 2 To 転記先.Cells(Rows.Count, "A").End(xlUp).Row                '転記先シートをループ
        社員 = 転記先.Cells(i, "D")
        If 社員 <> "社員名" Then                                            'タイトル行でないなら
            転記先.Cells(i, "E") = "": 転記先.Cells(i, "F") = ""            '出勤・退勤時刻を消去
        End If
        If 社員 <> "" And 社員 <> "社員名" And 社員 <> エラー Then          '転記処理の実行判定
            On Error Resume Next
            Set 転記元 = Workbooks("転記元book.xlsx").Worksheets(社員)      '転記元シートを指定
            If Err.Number <> 0 Then エラー = 社員                           '異常シート名を退避
            If Err.Number = 0 Then エラー = ""                              '異常シート名をクリア
            On Error GoTo 0
            If エラー = "" Then                                             'シート異常で無ければ
                For j = 2 To 転記元.Cells(Rows.Count, "A").End(xlUp).Row    '転記元シートをループ
                    If 転記先.Cells(i, "A") = 転記元.Cells(j, "A") And _
                       転記先.Cells(i, "C") = 転記元.Cells(j, "D") Then     '日付と部署が一致なら
                        転記先.Cells(i, "E") = 転記元.Cells(j, "F")         '出勤時刻を転記
                        転記先.Cells(i, "F") = 転記元.Cells(j, "G")         '退勤時刻を転記
                        Exit For                                            '次の社員へ移行
                    End If
                Next j
            End If
        End If
    Next i
End Sub