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

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


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


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

Preview




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

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



03-02-2020 11:30 صباحا
ayoub2007
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 24-11-2017
رقم العضوية : 1867
المشاركات : 88
الجنس : ذكر
تاريخ الميلاد : 23-12-1970
يتابعهم : 1
يتابعونه : 1
قوة السمعة : 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
المشاركات : 545
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 26
قوة السمعة : 4129
الاعجاب : 203
 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







المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
شرح كود دالة ubound & lbound مع المصفوفات المبتدأ
1 106 المبتدأ
تعديل كود( i*nputBox) احمد 9598
2 264 احمد 9598
كود بحث في شيت عن طريق i*nput box احمد 9598
0 206 احمد 9598
ضبط كود تحويل ملف Pdf الى إكسيل هانى على
14 758 YasserKhalil
مساعدة في كود للدالة vlookup المبتدأ
5 367 المبتدأ

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


 







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

الساعة الآن 07:17 صباحا

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