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



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







25-04-2020 06:23 مساءً
عندى ثلاث مدارس كل مدرسة بها مجموعة من الموظفين تم كتابه اكواد لأول ثلاثة المطلوب اريد تكمله الاكواد لباقى المدارس المكررة لا اريد عمليه الترتيب والسحب ملحوظه المدارس عندى اكثر من 400 مدرسة والموظفين 20 الف موظف
 
 
  تكملة اكواد المدارس2.xlsx   تحميل xlsx مرات التحميل :(8)
الحجم :(9.703) KB





look/images/icons/i1.gif استكمال باقى اكواد المدارس
  25-04-2020 08:06 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
جرب هذا الكود
CODE

Option Explicit

Sub give_data()
  Dim D As Object
  Dim S As Worksheet
  Dim S_rg As Range, Trg As Range
  Dim Ro%, y, m%, itm

  Set D = CreateObject("Scripting.Dictionary")
  Set S = Sheets("Sheet2")
  Set S_rg = S.Range("A1").CurrentRegion.Columns(2)
  Set S_rg = S_rg.Offset(1).Resize(S_rg.Rows.Count - 1)
  Set Trg = S.Range("F1").CurrentRegion

If Trg.Rows.Count > 1 Then Trg.Offset(1) _
.Resize(Trg.Rows.Count - 1).ClearContents
Ro = 1
 Do Until Ro > S_rg.Rows.Count
    If S_rg.Cells(Ro) <> vbNullString Then
        If Not D.Exists(S_rg.Cells(Ro).Value) Then
          D(S_rg.Cells(Ro).Value) = _
          S_rg.Cells(Ro).Offset(, 1).Value
        Else
          D(S_rg.Cells(Ro).Value) = _
          D(S_rg.Cells(Ro).Value) & "*" _
          & S_rg.Cells(Ro).Offset(, 1).Value
        End If
     End If
    Ro = Ro + 1
 Loop
  m = 2
 For Each y In D.keys
  Cells(m, "F") = y
  itm = Split(D(y), "*")
    Cells(m, "G").Resize(, UBound(itm) + 1) = itm
   m = m + 1
 Next
  With Cells(2, "E").Resize(m - 2)
    .Formula = "=INDEX(A1:A" & Ro & _
     ",MATCH(F2,B1:B" & Ro & ",0))"
    .Value = .Value
  End With
  
  Set D = Nothing: Set S = Nothing
  Set S_rg = Nothing: Set Trg = Nothing

End Sub


الملف مرفق
 
 
  Shool_codes.xlsm   تحميل xlsm مرات التحميل :(5)
الحجم :(28.919) KB


أثارت هذه المشاركة إعجاب: ali mohamed ali، مدحت حافظ،



look/images/icons/i1.gif استكمال باقى اكواد المدارس
  25-04-2020 08:45 مساءً   [2]
معلومات الكاتب ▼
تاريخ الإنضمام : 08-02-2018
رقم العضوية : 4244
المشاركات : 57
الجنس :
تاريخ الميلاد : 14-11-1976
قوة السمعة : 38
الاعجاب : 0
شكرا استاذ سليم ولكن ما اريد هو انى اضع امام كل مدرسة كودها وهى فى مكانها مش عايز الطريقة الكود




look/images/icons/i1.gif استكمال باقى اكواد المدارس
  25-04-2020 09:21 مساءً   [3]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
CODE
=IF(B5="","",IF(COUNTIF($B$2:B4,B5)>=1,INDEX($A$2:A4,MATCH(B5,$B$2:B4,0)),""))

الصفحة salim من هذا الملف
 
 
  Shool_codes_1.xlsm   تحميل xlsm مرات التحميل :(7)
الحجم :(32.546) KB


أثارت هذه المشاركة إعجاب: ali mohamed ali، هاوي برمجه، أحمد يوسف، محمدمطر، مالك ماريه،



look/images/icons/i1.gif استكمال باقى اكواد المدارس
  25-04-2020 10:39 مساءً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 226
الجنس :
الدعوات : 4
قوة السمعة : 2147
الاعجاب : 19
السلام عليكم ورحمة الله
يمكنك استخدام الكود التالى
CODE
Sub Sch_Cods()
Dim i As Long
Dim j As Long
Dim LR As Long
Dim ws As Worksheet
Dim Arr As Variant
Dim Sch As String
Dim Cnt As Integer
Application.ScreenUpdating = False
Set ws = Sheets("Sheet2")
LR = ws.Range("B" & Rows.Count).End(xlUp).Row
Arr = ws.Range("A2:B4").Value
For j = 1 To UBound(Arr, 1)
Sch = Arr(j, 2)
Cnt = Arr(j, 1)
i = 2
Do While i <= LR
If ws.Cells(i, 2) = Sch Then
ws.Cells(i, 1) = Cnt
End If
i = i + 1
Loop
Next
Application.ScreenUpdating = True
End Sub

أثارت هذه المشاركة إعجاب: هاوي برمجه، ali mohamed ali، YasserKhalil، أحمد يوسف، Yasser Elaraby، محمدمطر، مالك ماريه، مدحت حافظ،



look/images/icons/i1.gif استكمال باقى اكواد المدارس
  26-04-2020 07:55 صباحاً   [5]
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس :
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 6611
الاعجاب : 2
بعد اذن اخي ابراهيم
هذا الكود زيادة في اثراء الموضوع
CODE

Sub Sal_Cods()
Dim LR As Long
Dim ws As Worksheet
Dim i%, N
Application.ScreenUpdating = False
 Set ws = Sheets("Sheet2")
LR = ws.Range("B" & Rows.Count).End(xlUp).Row

For i = 5 To LR
 Select Case Cells(i, 2)
    Case Cells(2, 2): N = Cells(2, 1)
    Case Cells(3, 2): N = Cells(3, 1)
    Case Cells(4, 2): N = Cells(4, 1)
    Case Else: N = ""
  End Select
 Cells(i, 1) = N
Next

Application.ScreenUpdating = True
End Sub


أثارت هذه المشاركة إعجاب: YasserKhalil، Yasser Elaraby، هاوي برمجه، محمدمطر، مالك ماريه، مدحت حافظ،



look/images/icons/i1.gif استكمال باقى اكواد المدارس
  26-04-2020 12:02 مساءً   [6]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10516
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36718
الاعجاب : 170
الأخ الكريم محمد لم يؤكد صحة النتائج ولكن بناءً على فهمت من الأكواد المقدمة يمكن تجربة الكود بهذا الشكل
CODE
Sub Test()
    Dim a, dic As Object, i As Long
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 2 To 4
        dic.Add Cells(i, 2).Value, Cells(i, 1).Value
    Next i
    a = Range("A5:B" & Cells(Rows.Count, 2).End(xlUp).Row).Value
    For i = LBound(a) To UBound(a)
        a(i, 1) = dic(a(i, 2))
    Next i
    Range("A5").Resize(UBound(a)).Value = a
End Sub

أثارت هذه المشاركة إعجاب: ali mohamed ali، Yasser Elaraby، هاوي برمجه، محمدمطر، مالك ماريه، مدحت حافظ،



look/images/icons/i1.gif استكمال باقى اكواد المدارس
  26-04-2020 11:30 مساءً   [7]
معلومات الكاتب ▼
تاريخ الإنضمام : 08-02-2018
رقم العضوية : 4244
المشاركات : 57
الجنس :
تاريخ الميلاد : 14-11-1976
قوة السمعة : 38
الاعجاب : 0
والله يا جماعة انا شكرا لكم جزيل الشكر والتقدير والعرفان على مساعدتى وجعله الله فى ميزان حسناتكم

أثارت هذه المشاركة إعجاب: YasserKhalil، مدحت حافظ،



look/images/icons/i1.gif استكمال باقى اكواد المدارس
  26-04-2020 11:39 مساءً   [8]
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10516
الجنس :
تاريخ الميلاد : 1-10-1978
الدعوات : 24
قوة السمعة : 36718
الاعجاب : 170
بارك الله فيك أخي الكريم والحمد لله أن تم المطلوب على خير
والحمد لله الذي بنعمته تتم الصالحات

أثارت هذه المشاركة إعجاب: مدحت حافظ،



اضافة رد جديد اضافة موضوع جديد




الكلمات الدلالية
استكمال ، باقى ، اكواد ، المدارس ،








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

الساعة الآن 04:15 PM.