ترحيل الغياب بدون فراغات

[khairi ali]

Tarhil_3iyab.xlsm

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

من باب العرفان بالجميل واحتراماً لشيء يدعى "حقوق الملكية الفكرية"

كان يجب عليك ان تذكر من وضع لك الكود الذي تعمل عليه في الملف

تم التعديل على الكود كما تريد

Option Explicit
Sub ABSCENT_new()
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 + 1)

 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, "T")
       .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 (2).xlsm

[khairi ali]

استاذ سليم انا اعترف بأن هذا الكود من شغلك انت ولك فائق الشكر وانا أتعلم من حضرتكم ولم اقل اني صاحب هذا الكود

استاذ سليم هناك مشكلة صغيرة 

وهي تغير اتجاة أرقام أيام الغياب مثلا  5-6-16-23 بهذه الطريقة وليس 23-16-6-5

وشكرا 

 

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

انا لم اقل انك انت من كتب الكود 

حتى و لو لم اكن انا من وضع الكود  (أي شخص اخر)    يجب ان تذكر صاحبه 

[khairi ali]

مشكور استاذ سليم 

قد ظهرت مشكلة وهي عند تغير الشهر تظهر هذه الرشالة

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

تم معالجة الامر مع بعض التحسينات على الكود

Option Explicit

Sub ABSCENT_EXTRA()
Application.Calculation = xlCalculationManual
  Dim K As Worksheet, A As Worksheet
  Dim Ro_K%, col%, NUM%, Ro_A%, x%, 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 + 1)
  NUM = m
 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 = 36 To 6 Step -1
            If K.Cells(i, col) = Str Then
             ALL = ALL & col - 5 & "-"
            End If
         Next col
        For col = 6 To 36
            If K.Cells(i, col) = Str Then
             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, "T")
       .Offset(, 4) = Year(Date)
      End With
      
      m = m + 1
      End If
My_next:

    t = 1
    ALL = " ": ALPHA = " "
    x = x + 1
 Next i
  With A.Range("b" & NUM).Resize(x, 7)
  .ClearFormats
  .InsertIndent 1
  .Borders.LineStyle = 1
  End With
 Application.Calculation = xlCalculationAutomatic
End Sub

 

Tarhil_3iyab (3).xlsm

[khairi ali]

عمل رائع استاذ سليم 

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