استدعاء الغائبين

[محمد عدنان]

السلام عليكم  و رحمة الله و بركاته 

ارجو المساعدة في الملف المرفق بماكرو يقوم بترحيل اسم الطالب الغائب الى بجانبه كلمة غائب الى اليوم الموفق للغياب  علما بان الترحيل يكون يومي و الطباعة تكون اخر الشهر للاحصائية .. المطلوب ترحيل اسم الطالب الموجود بجانبه كلمة غائب مع الانتباه عتد ترحيل اسم الطالب الانتباه للتاريخ 

و شكرا لكم 

Absence 2022.xlsm

[lionheart]

Change the worksheet code names in VBE window to wsList and wsMonthlyAbsence

Sub Test()
    Dim x, v, f As Boolean, sTemp As String, lr As Long, c As Long, tot As Long, r As Long, m As Long, i As Long, ii As Long, col As Long
    Application.ScreenUpdating = False
        With wsList
            lr = .Cells(Rows.Count, "D").End(xlUp).Row
            wsMonthlyAbsence.Range("C6:J100").Value = Empty
            For c = 5 To 36
                tot = Application.WorksheetFunction.CountA(.Range(.Cells(8, c), .Cells(lr, c)))
                If tot = 0 Then GoTo NXT
                f = True: m = 0: col = 0: sTemp = vbNullString
                For r = 8 To lr
                    If .Cells(r, c).Value <> "" Then
                        x = Application.Match(.Cells(7, c).Value2, wsMonthlyAbsence.Columns(2), 0)
                        If Not IsError(x) Then
                            If f Then
                                wsMonthlyAbsence.Cells(x, "C").Value = tot
                                wsMonthlyAbsence.Cells(x, "D").Value = lr - 8 + 1 - tot
                                f = False
                            End If
                            sTemp = sTemp & IIf(sTemp = Empty, Empty, ",") & .Cells(r, 4).Value
                        End If
                    End If
                Next r
                If sTemp <> Empty Then
                    v = Split(sTemp, ",")
                    For i = LBound(v) To UBound(v) Step 3
                        For ii = 0 To 2
                            m = m + 1
                            If m > UBound(v) + 1 Then Exit For
                            wsMonthlyAbsence.Cells(x + ii, col + 5).Value = v(i + ii)
                        Next ii
                        col = col + 1
                    Next i
                End If
NXT:
            Next c
        End With
    Application.ScreenUpdating = True
    MsgBox "Done...", 64, "LionHeart"
End Sub

 

[محمد عدنان]

السلام عليكم 

اخ @lionheart جزاك الله الجنة و بارك الله بك  الكود يعمل بشكل حيد 

شكرا جزيلا لك و بارك الله بك 

[سيد الأكـرت]

ممكن رفع الملف ده بالكود لو سمحت لنستفيد منه 

[بلانك]

يعطي خطأ ماالسبب استاذي lionheart

[lionheart]

Maybe there's an extra space at the end of the worksheet code name wsList

[بلانك]

Very good & Thavk u