كود ترحيل غيابات

[مجاهد2013]

السلام عليكم
أحتاج كود لترحيل الغيابات من شيت"p" إلى شيت " غيابات الأساتذة " حسب الجدول بحيث :
عند وضع حرف غ للاستاذ الغائب يقوم بترحيله إلى شيت غيابات الاساتذة وفق الجدول الزمني المخصص له من شيت "  t "
و شكرا

med.xls

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

سبق وقلت لك ان الجدول لا يتناسب مع المعطيات

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

السؤال:

كيف تريد ان توزع ايام الغياب (التواريخ) في صف واحد

لو اخذنا مثلاً الاستاذ باري عامر عنده 6 غيابات في تواريخ مختلفة كيف تدرج هذه التواريخ في الصف السادس وفي خلية واحدة ( (A6

ملاحظة :لم احذف الصفحات الباقية بل فقط اخفيتها حتى اتعامل مع الصفات المطلوبة مؤقتاً

يرجى اعادة تصميم الجدول اذا كنت تريد تواريخ كل الغيابات للغائبين مع العلم انه يمكن ان يكون هتاك اكثر من مرة غياب فب في شهر واحد

الشرح اكثر وضوحاً في الملف المرفق

الكود

Option Explicit
Sub fil_name()
Dim p As Worksheet, t As Worksheet, G As Worksheet
Dim x%, m%, how_many%
Dim resl As Range, r%
Set p = Sheets("P"): Set t = Sheets("T")
Set G = Sheets("GHIAB")
Set resl = G.Range("a5").CurrentRegion
 r = resl.Rows.Count
 If r > 1 Then resl.Offset(1).Resize(r - 1).ClearContents
x = 4: m = 6
 Do Until p.Range("a" & x) = vbNullString
  how_many = Application.CountIf(p.Range("D" & x).Resize(, 222), "Ok")
  If how_many > 0 Then
  With G.Cells(m, 1)
    .Value = how_many
    .Offset(, 1) = p.Cells(x, 1)
    .Offset(, 2) = p.Cells(x, 2)
    .Offset(, 3) = p.Cells(x, 3)
    m = m + 1
  End With
  End If
  x = x + 1
  Loop
  
End Sub

الملف مرفق     (تم تغيير اسم صفحة الغائبين الى GHIAB)   لسهولة التعامل مع اللغة الاجنبية من حيث نسخ الكود ولصقه

 

medSalim.xlsm

[مجاهد2013]

أولا ألف شكرا أستاذ سليم فغالبا ما أجدك بجانبي ـ سأبعث لك صورتين لتوصيح المطلوب .

و هكذا تكون الغيابات متتالية حسب الأيام

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

تم معالجة الخطوة الأولى

Sub fil_Profname()
  Application.ScreenUpdating = False
  Dim p As Worksheet, t As Worksheet, G As Worksheet
  Dim x%, m%, how_many%, r%, i%, y%, mun%: num = 1
  Dim resl As Range, F_rg As Range
  Dim Mth As Range, arr(), cel As Range

  Set p = Sheets("P"): Set t = Sheets("T")
  Set G = Sheets("GHIAB")
  Set resl = G.Range("a5").CurrentRegion
   r = resl.Rows.Count
 If r > 1 Then resl.Offset(1).Resize(r - 1).Clear
    x = 4: m = 6
 Do Until p.Range("a" & x) = vbNullString
 '======================================
         how_many = Application.CountIf(p.Range("D" & x).Resize(, 222), "Ok")
          If how_many = 0 Then GoTo Next_x
           Set Mth = G.Range("O12:o23").Find(G.Range("O5")).Offset(, 1)
             For Each cel In p.Range("D" & 3).Resize(, 222)
               If Month(cel) = Mth And UCase(cel.Offset(x - 3)) = "OK" Then
                ReDim Preserve arr(1 To num)
                arr(num) = cel
                num = num + 1
               End If
             Next
             If num > 1 Then
              G.Cells(m, 1).Resize(num - 1) = Application.Transpose(arr)
                For i = 1 To how_many
                 G.Cells(m + i - 1, 2) = p.Cells(x, 1)
                 G.Cells(m + i - 1, 3) = p.Cells(x, 2)
                 G.Cells(m + i - 1, 4) = p.Cells(x, 3)
                Next
               m = m + how_many
             End If
          Erase arr: num = 1
Next_x:
          x = x + 1

  Loop
 Set resl = G.Range("a5").CurrentRegion
 r = resl.Rows.Count
 If r = 1 Then Exit Sub
 Set resl = resl.Offset(1).Resize(r - 1)
  With resl
   .InsertIndent 1
   .Borders.LineStyle = 1
   .Font.Bold = True
   .Font.Size = 14
  End With
  Application.ScreenUpdating = True
End Sub

 

medSalim_1.xlsm

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

تم معالجة الامر بالكامل

Sub fil_Profname()
  Application.ScreenUpdating = False
  Dim p As Worksheet, T As Worksheet, G As Worksheet
  Dim x%, xx%, m%, how_many%, r%, i%, y%, mun%: num = 1
  Dim resl As Range, F_rg As Range
  Dim Mth As Range, arr(), cel As Range
  Dim D_arr()
  Set p = Sheets("P"): Set T = Sheets("T")
  Set G = Sheets("GHIAB")
  Set resl = G.Range("a5").CurrentRegion
   
   r = resl.Rows.Count
 If r > 1 Then resl.Offset(1).Resize(r - 1).Clear
    x = 4: m = 6
 Do Until p.Range("a" & x) = vbNullString
 '======================================
         how_many = Application.CountIf(p.Range("D" & x).Resize(, 500), "Ok")
          If how_many = 0 Then GoTo Next_x
           Set Mth = G.Range("P12:P23").Find(G.Range("P5")).Offset(, 1)
           first = Application.Match(Mth, p.Cells(500, "d").Resize(, 250), 0) + 3
           y = Application.CountIf(p.Rows(500), Mth)

             For Each cel In p.Cells(3, first).Resize(, y)
               If Month(cel) = Mth And UCase(cel.Offset(x - 3)) = "OK" Then
                ReDim Preserve arr(1 To num)
                ReDim Preserve D_arr(1 To num)
                arr(num) = CDate(cel)
                D_arr(num) = cel.Offset(-1)
                num = num + 1
               End If
             Next
             If num > 1 Then
              G.Cells(m, 1).Resize(num - 1) = Application.Transpose(arr)
              G.Cells(m, 2).Resize(num - 1) = Application.Transpose(D_arr)
                For i = 1 To num - 1
                 G.Cells(m + i - 1, 3) = p.Cells(x, 1)
                 G.Cells(m + i - 1, 4) = p.Cells(x, 2)
                 G.Cells(m + i - 1, 5) = p.Cells(x, 3)
                 
                Next
                      
                m = m + num - 1
             End If
          Erase arr: Erase D_arr: num = 1
Next_x:
          x = x + 1

  Loop
  
 Set resl = G.Range("a5").CurrentRegion
 r = resl.Rows.Count
 If r = 1 Then Exit Sub
  Set resl = resl.Offset(1).Resize(r - 1)

  With resl
   .InsertIndent 1
   .Borders.LineStyle = 1
   .Font.Bold = True
   .Font.Size = 14
  End With
  MADDA
  Application.ScreenUpdating = True
End Sub
'================================
Sub MADDA()

  Dim T As Worksheet, G As Worksheet
  Dim x%, xx%, m%, r1%
  Dim F_rg As Range
  
  Set T = Sheets("T")
  Set G = Sheets("GHIAB")

  x = 6: m = 6
Do Until G.Range("A" & x) = vbNullString
     xx = T.Rows(1).Find(G.Range("B" & x)).Column
      Set F_rg = T.Columns(1).Find(G.Range("C" & x), lookat:=1)
       If F_rg Is Nothing Then GoTo Next_x
       r1 = F_rg.Row
       G.Cells(m, 6).Resize(, 8).Value = _
       T.Cells(r1, xx).Resize(, 8).Value
       m = m + 1
Next_x:
    x = x + 1
Loop
End Sub

الملف

 

medSalim_Final.xlsm

[مجاهد2013]

تمام التمام ألف شكر مع تحياتي أستاذ سليم