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

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


اعلان هنا
صقور الاكسيل
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا


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





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

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



03-02-2020 11:30 صباحا
ayoub2007
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 78
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
قوة السمعة : 45
الاعجاب : 3
 offline 
السلام عليكم
أحتاج كود لترحيل اغيابات من شيت"p" إلى شيت " غيابات الأساتذة " حسب الجدول بحيث :
عند وضع حرف غ للاستاذ الغائب يقوم بترحيله إلى شيت غيابات الاساتذة وفق الجدول الزمني المخصص له من شيت "  t "
و شكرا
 
 
  med.xls   تحميل xls مرات التحميل :(8)
الحجم :(136.192) KB





05-02-2020 11:04 مساء
مشاهدة مشاركة منفردة [1]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 492
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 3816
الاعجاب : 65
 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 مرات التحميل :(5)
الحجم :(95.864) KB







المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
تعديل كود( i*nputBox) احمد 9598
2 158 احمد 9598
كود بحث في شيت عن طريق i*nput box احمد 9598
0 148 احمد 9598
ضبط كود تحويل ملف Pdf الى إكسيل هانى على
14 600 YasserKhalil
مساعدة في كود للدالة vlookup المبتدأ
5 281 المبتدأ
تعديل كود تخزين الفاتورة على هيئة pdf المبتدأ
9 362 YasserKhalil

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


 







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

الساعة الآن 11:51 مساء

أعلن هنا
أعلن هنا
أعلن هنا