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

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


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





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

عندى ثلاث مدارس كل مدرسة بها مجموعة من الموظفين تم كتابه اكواد لأول ثلاثة المطلوب اريد تكمله الاكواد لباقى المدارس المكر ..



25-04-2020 06:23 مساء
محمدمطر
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 08-02-2018
رقم العضوية : 4244
المشاركات : 60
الجنس : ذكر
تاريخ الميلاد : 14-11-1976
يتابعهم : 8
يتابعونه : 0
قوة السمعة : 38
 offline 

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


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

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


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

25-04-2020 09:21 مساء
مشاهدة مشاركة منفردة [3]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif استكمال باقى اكواد المدارس
=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


25-04-2020 10:39 مساء
مشاهدة مشاركة منفردة [4]
ابراهيم الحداد
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 231
الجنس : ذكر
الدعوات : 4
يتابعهم : 0
يتابعونه : 33
قوة السمعة : 2149
عدد الإجابات: 28
 offline 
look/images/icons/i1.gif استكمال باقى اكواد المدارس
السلام عليكم ورحمة الله
يمكنك استخدام الكود التالى
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

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

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


26-04-2020 12:02 مساء
مشاهدة مشاركة منفردة [6]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10439
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 0
يتابعونه : 533
قوة السمعة : 36372
عدد الإجابات: 252
 offline 
look/images/icons/i1.gif استكمال باقى اكواد المدارس
الأخ الكريم محمد لم يؤكد صحة النتائج ولكن بناءً على فهمت من الأكواد المقدمة يمكن تجربة الكود بهذا الشكل
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




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


 










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

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