ترحيل الغياب

[khairi ali]

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

اخواني أعضاء المنتدى اشكركم على تقديم يد العون للجميع

لدي سؤال مرفق في الملف وهو بخصوص ترحيل الغياب من شيت الغياب إلى شيت الارشيف شهريا 

وشكرا مقدما

ترحيل الغياب.xlsm

[سليم حاصبيا]

جرب هذا الماكرو

Option Explicit
Sub ABSCENT()
Application.Calculation = xlCalculationManual
  Dim K As Worksheet, A As Worksheet
  Dim Ro_K%, col%, Ro_A%, i%, m%, t%: t = 1
  Dim ALL$, ALPHA$, Str$: Str = "غ"
  ALL$ = " ": ALPHA = " "
Set K = Sheets("keab"): Set A = Sheets("arhkeab")
Ro_K = K.Cells(Rows.Count, 2).End(3).Row
If Ro_K < 5 Then Exit Sub
  Ro_A = A.Cells(Rows.Count, 2).End(3).Row
  m = IIf(Ro_A < 5, 5, Ro_A + 2)

 For i = 5 To Ro_K
      If Application.CountIf(K.Cells(i, 6).Resize(1, 31), Str) = 0 Then _
      GoTo My_next
        A.Cells(m, 2).Resize(, 2).Value = _
        K.Cells(i, 2).Resize(, 2).Value
        
        For col = 6 To 36
            If K.Cells(i, col) = Str Then
             ALL = ALL & Day(K.Cells(4, col)) & "-"
             ALPHA = ALPHA & K.Cells(3, col) & "-"
             t = t + 1
            End If
         Next col
      
      If t > 1 Then
      With A.Cells(m, 4)
       .Value = Mid(ALL, 1, Len(ALL) - 1)
       .Offset(, 1) = Mid(ALPHA, 1, Len(ALPHA) - 1)
       .Offset(, 2) = t - 1
       .Offset(, 3) = K.Cells(2, "Q")
       .Offset(, 4) = Year(Date)
      End With
      
      m = m + 1
      End If
My_next:
    t = 1
    ALL = " ": ALPHA = " "
 Next i
 Application.Calculation = xlCalculationAutomatic
End Sub

الملف مرفق

Tarhil_3iyab.xlsm

[khairi ali]

مشكور جدا استاذي سليم  .. وبارك الله فيك وان شاء الله في ميزان حسانتك