ترحيل الغيابات إلى سجل الغيابات حسب الحصص

Sub Test()

    Dim a, x, y, z, ws As Worksheet, sh As Worksheet, i As Long

    

    Application.ScreenUpdating = False

    Application.EnableEvents = False

        Set ws = ThisWorkbook.Worksheets("TAKABS")

        Set sh = ThisWorkbook.Worksheets("DAFTAR")

        

        a = ws.Range("A3:A" & ws.Cells(Rows.Count, 1).End(xlUp).Row).Value

        

        For i = LBound(a) To UBound(a)

            x = Application.Match(a(i, 1), sh.Columns(2), 0)

            If Not IsError(x) Then

                y = Application.Match(ws.Range("B1").Value2, sh.Rows(12), 0)

                If Not IsError(y) Then

                    z = Application.Match(ws.Range("G1").Value, sh.Cells(12, y).Offset(2).Resize(1, 8), 0)

                    If Not IsError(z) Then

                        sh.Cells(x, y + z - 1).Value = "X"

                        Debug.Print sh.Cells(x, y + z - 1).Address

                    End If

                End If

            End If

        Next i

    Application.EnableEvents = True

    Application.ScreenUpdating = True

End Sub