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

[shetos77]

السلام عليكم ارجوا المساعدة المطلوب داخل الشيت 

استدعاء الغياب.xls

استدعاء الغياب.rar

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

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

Option Explicit
Sub tarnsfer_daya()
Dim Rg1 As Range: Set Rg1 = DATA.Range("a5").CurrentRegion
Dim last_ro%: last_ro = Rg1.Rows.Count
Dim last_col%: last_col = Rg1.Columns.Count
Dim lr%: lr = ABSCENT.Cells(Rows.Count, 1).End(3).Row
ABSCENT.Range("B7:S" & lr).ClearContents
Dim i%, K%, St$, mtch%
Dim m%: m = 7
 For i = 7 To last_ro + 4
 For K = 4 To last_col - 7
  If DATA.Cells(i, K) = "غ" Then
      St = DATA.Cells(5, K)
      On Error Resume Next
      mtch = Application.Match(St, ABSCENT.Rows(5), 0)
      If Err.Number <> 0 Then
      On Error GoTo 0
      GoTo 1
      End If
      ABSCENT.Cells(m, mtch) = DATA.Cells(i, "B")
      ABSCENT.Cells(m, mtch + 1) = DATA.Cells(i, "C")
   End If
1:
 Next
  m = m + 1
 Next
End Sub

الملف مرفق

Salim_Abscent.xlsm

[Ali Mohamed Ali]

احسنت استاذ سليم كود رائع جعله الله فى ميزان حسناتك

[shetos77]

مشكور اخي الاستاذ سليم ولكن هل يمكن ان يكون اسماء الغائبين اسفل كل مادة بدون صفوف فارغة حتي يكون حصر الغياب سهل حتي لو كان الشيت به عدد كبير من الطلبه

تم تعديل يناير 25, 2019 بواسطه shetos77

[بن علية حاجي]

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

حل بالمعادلات في الملف المرفق...

بن علية حاجي

استدعاء الغياب.xls

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

6 ساعات مضت, shetos77 said:

مشكور اخي الاستاذ سليم ولكن هل يمكن ان يكون اسماء الغائبين اسفل كل مادة بدون صفوف فارغة حتي يكون حصر الغياب سهل حتي لو كان الشيت به عدد كبير من الطلبه

لك هذا

الكود

Option Explicit
Sub find_abscent()
Application.ScreenUpdating = False
Dim Sh1 As Worksheet: Set Sh1 = Sheets("الشيت")
Dim Sh2 As Worksheet: Set Sh2 = Sheets("abscent")
Dim my_rg As Range: Set my_rg = Sh1.Range("c5").CurrentRegion
Sh2.Range("TETE_RG").ClearContents
Dim i%, k%: k = 1
Dim m%: m = 2
Dim arr(1 To 9)
 For i = 2 To 18 Step 2
  arr(k) = Sh2.Cells(3, i)
  k = k + 1
  Next
  k = 3
 
 For i = LBound(arr) To UBound(arr)
  my_rg.AutoFilter k, "غ"
  k = k + 1
  my_rg.Columns(1).SpecialCells(12).Copy _
   Sh2.Cells(4, m)
   m = m + 1
  my_rg.Columns(2).SpecialCells(12).Copy _
   Sh2.Cells(4, m)
   m = m + 1
  my_rg.AutoFilter
  Next

  Erase arr: Set my_rg = Nothing
  Application.ScreenUpdating = True
End Sub

الملف مرفق

 

Abscet_Salim.xlsm

[بن علية حاجي]

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

وهذا حل أخي الكريم سليم بعد إذنه وبعد تعديل طفيف على كوده الأول...

بن علية حاجي

Salim_Abscent.xlsm

[وجيه شرف الدين]

بارك الله فيكم وفي اعمالكم وجزاكم الله خير الجزاء وجعله الله فى ميزان حسناتكم