أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
كريم نظيم مجدى يونس-- لا تميز خلال هذه الفترة لا تميز خلال هذه الفترة بحاجة الى كود ترحيل اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





كود لترحيل الغيابات من شيت p إلى شيت غيابات الأساتذة

السلام عليكم أحتاج كود لترحيل اغيابات من شيتquot;pquot; إلى شيت quot; غيابات الأساتذة quot; حسب الجدول بحيث : عند وضع حر ..



03-02-2020 11:30 صباحا
ayoub2007
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 157
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 3
يتابعونه : 1
قوة السمعة : 106
 offline 

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


05-02-2020 11:04 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif كود لترحيل الغيابات من شيت p إلى شيت غيابات الأساتذة
جرب هذا الماكرو

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   تحميل xlsm مرات التحميل :(8)
الحجم :(95.864) KB





الكلمات الدلالية
الترحيل ،


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 12:08 مساء