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

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


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


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

Preview




استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس

الملف عبارة عن جزء من قاعدة سنتر تعليمى والكود الموجود بالملف من اعداد الاستاذ العلامة ياسر خليل وهو : quot; كود استخرا ..



01-04-2020 07:07 مساء
ayman_2000
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 04-09-2017
رقم العضوية : 337
المشاركات : 84
الجنس : ذكر
تاريخ الميلاد : 14-5-1963
يتابعهم : 3
يتابعونه : 2
قوة السمعة : 153
الاعجاب : 17
 offline 
الملف عبارة عن جزء من قاعدة سنتر تعليمى
والكود الموجود بالملف من اعداد الاستاذ العلامة ياسر خليل وهو :
 " كود استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس "
والكود يعمل بكفاءة على الجزء الأول من الشيت والمحدد بالاعمدة من A : L ذات اللون الأخضر
ولكن من المعلوم بأن الطالب الواحد يمكن ان يشترك مع اكثر من مدرس في اكثر من مادة
وبما ان القاعدة مصممة بالاكسيل  فالطالب يخصة صف واحد فقط حتى لو اشترك في اكثر من مادة
المطلوب :
تعديل الكود الموجود بالملف المرفق بحيث يقوم بتجميع حسابات المدرسين في الاعمدة من A : V
ويضع النتائج فى الورقة nour

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  سنتر تعليمى.rar   تحميل rar مرات التحميل :(4)
الحجم :(54.219) KB





01-04-2020 10:01 مساء
مشاهدة مشاركة منفردة [1]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 545
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 26
قوة السمعة : 4125
الاعجاب : 201
 offline 
look/images/icons/i1.gif استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس
جرب هذا الكود

Option Explicit
Sub Mycode()
Dim dic As Object
Dim A As Worksheet
Dim N As Worksheet
Dim m%, i%, ky, t%, last_ro%, Fix_Ro%, Act_Ro%
Dim Rg_A As Range, F_rg As Range
Dim arr_col()

Application.ScreenUpdating = False
Set A = Sheets("ayman"): Set N = Sheets("nour")
Set Rg_A = A.Range("a4").CurrentRegion.Columns(2)
Set dic = CreateObject("Scripting.Dictionary")
If N.Range("c1").CurrentRegion.Rows.Count > 1 Then _
    N.Range("c1").CurrentRegion.Offset(1).Clear
For i = 2 To Rg_A.Rows.Count
 dic(Rg_A.Cells(i).Value) = vbNullString
 Next
 arr_col = Array(2, 4, 5, 11, 12, 14, 15, 21, 22)

 m = 2
 For Each ky In dic.keys
  Set F_rg = Rg_A.Find(ky, Lookat:=1)
   Fix_Ro = F_rg.Row: Act_Ro = Fix_Ro
    Do
    t = t + 1
      With N.Cells(m, 2)
        For i = 0 To 8
         .Offset(, i) = A.Cells(Act_Ro, arr_col(i))
        Next
      End With
       m = m + 1
      Set F_rg = Rg_A.FindNext(F_rg)
      Act_Ro = F_rg.Row
      If Act_Ro = Fix_Ro Then Exit Do
   Loop
    Cells(m, 1) = "المجموع"
    Cells(m, 5).Resize(, 2).Formula = "=SUM(E" & m - t & ":E" & m - 1 & ")"
    Cells(m, 9).Resize(, 2).Formula = "=SUM(I" & m - t & ":I" & m - 1 & ")"
    Cells(m, 1).Resize(, 10).Interior.ColorIndex = 6
    m = m + 1
    t = 0
  Next ky
      With N.Range("A1").CurrentRegion
        .Borders.LineStyle = 1
        .InsertIndent 1
        .Font.Size = 14
        .Font.Bold = True
        .Columns.AutoFit
        .Value = .Value
        .Rows(1).HorizontalAlignment = xlCenter
      End With
  
  Set dic = Nothing: Set A = Nothing
  Set N = Nothing: Set Rg_A = Nothing
  Set F_rg = Nothing: Set dic = Nothing
  Erase arr_col
    
 Application.ScreenUpdating = trus

End Sub

الملف مرفق
 
 
  Accadimic_centre.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(101.681) KB


أثارت هذه المشاركة إعجاب: ayman_2000، YasserKhalil،



01-04-2020 11:12 مساء
مشاهدة مشاركة منفردة [2]
ayman_2000
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 04-09-2017
رقم العضوية : 337
المشاركات : 84
الجنس : ذكر
تاريخ الميلاد : 14-5-1963
يتابعهم : 3
يتابعونه : 2
قوة السمعة : 153
الاعجاب : 17
 offline 
look/images/icons/i1.gif استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس
اشكرك اخى الفاضل على اهتمامك 
ولكن المطلوب تقرير مجمع لحساب المدرسين كما في الصورة المرفقة
وكرر شكرى وامتنانى لحضرتك 
تقبل تحياتي 
 
NDM3NTQ2MQ6565Capture
 
 





02-04-2020 07:55 صباحا
مشاهدة مشاركة منفردة [3]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 545
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 26
قوة السمعة : 4125
الاعجاب : 201
 offline 
look/images/icons/i1.gif استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس
تم التعديل على الماكرو ليتناسب مع ما تريد

Option Explicit
Sub Mycode_new()
Dim Dic As Object
Dim ReP As Worksheet
Dim A As Worksheet
Dim m%, i%, ky, Fix_Ro%, Act_Ro%
Dim RG_D As Range, F_rg As Range
Dim arr_col()

Application.ScreenUpdating = False
Set ReP = Sheets("Repport"): Set A = Sheets("ayman")
Set RG_D = A.Range("A4").CurrentRegion.Columns(4)
Set Dic = CreateObject("Scripting.Dictionary")
If ReP.Range("C1").CurrentRegion.Rows.Count > 1 Then _
    ReP.Range("C1").CurrentRegion.Offset(1).Clear
For i = 2 To RG_D.Rows.Count
 Dic(RG_D.Cells(i).Value) = vbNullString
 Next
 arr_col = Array(4, 5, 11, 12, 14, 15, 21, 22)

 m = 2
 For Each ky In Dic.keys
  Set F_rg = RG_D.Find(ky, Lookat:=1)
   Fix_Ro = F_rg.Row: Act_Ro = Fix_Ro
   Do
        With ReP.Cells(m, 2)
          For i = 0 To 7
           .Offset(, i) = A.Cells(Act_Ro, arr_col(i))
          Next
        End With
         m = m + 1
        Set F_rg = RG_D.FindNext(F_rg)
        Act_Ro = F_rg.Row
        If Act_Ro = Fix_Ro Then Exit Do
   Loop
  Next ky
      With ReP.Range("B2").Resize(m - 2, 8)
        .Borders.LineStyle = 1
        .InsertIndent 1
        .Font.Size = 14
        .Font.Bold = True
      
      End With
  
  Set Dic = Nothing: Set ReP = Nothing
  Set A = Nothing: Set RG_D = Nothing
  Set F_rg = Nothing: Erase arr_col
  
    
 Application.ScreenUpdating = True

End Sub


الملف من جديد (الصفحة Repport)
 
 
 
  Accadimic_centre_new.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(116.287) KB


أثارت هذه المشاركة إعجاب: YasserKhalil، ali mohamed ali، ayman_2000،



02-04-2020 12:21 مساء
مشاهدة مشاركة منفردة [4]
ayman_2000
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 04-09-2017
رقم العضوية : 337
المشاركات : 84
الجنس : ذكر
تاريخ الميلاد : 14-5-1963
يتابعهم : 3
يتابعونه : 2
قوة السمعة : 153
الاعجاب : 17
 offline 
look/images/icons/i1.gif استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس
اشكرك اخى الفاضل سليم على اهتمامك لمساعدة اعضاء المنتدى
واشكرك على الحلول التى توصلت اليها
ولكن بعد محاولات توصلت الى حل للوصول الى النتائج المطلوبة 
بعد اضافة تعديلات طفيفة على كود الاستاذ ياسر خليل 
اعرضة على السادة خبراء المنتدى للتصحيح والتعديل علية
Sub ayman_333()

'الكود خاص بالاستاذ العلامة ياسر خليلاعزة الله
'وتم التعديل علية فى بعض الاماكن ليناسب النتائج
    
    Dim ws          As Worksheet
    Dim sh          As Worksheet
    Dim dic         As Object
    Dim a           As Variant
    Dim s           As String
    Dim i           As Long
    Dim j           As Long
    '--------------------------------------------------------------------------------
    Set ws = ThisWorkbook.Sheets("ayman")
    Set sh = ThisWorkbook.Sheets("nour")
    Set dic = CreateObject("scripting.dictionary")
    a = ws.Range("A3:V" & ws.Cells(Rows.Count, 2).End(xlUp).Row).Value
    '--------------------------------------------------------------------------------
    For i = LBound(a, 1) To UBound(a, 1)
        s = a(i, 4) & vbTab & a(i, 5)
        If Not dic.Exists(s) Then dic(s) = Array(, , 0, 0)
        dic(s) = Array(a(i, 4), a(i, 5), dic(s)(2) + a(i, 11), dic(s)(3) + a(i, 12))
    Next i
    '--------------------------------------------------------------------------------
    For j = LBound(a, 1) To UBound(a, 1)
        s = a(j, 14) & vbTab & a(j, 15)
        If Not dic.Exists(s) Then dic(s) = Array(, , 0, 0)
        dic(s) = Array(a(j, 14), a(j, 15), dic(s)(2) + a(j, 21), dic(s)(3) + a(j, 22))
    Next j
    '--------------------------------------------------------------------------------
    sh.Range("A1").Resize(1, 4).Value = Array("اســم المــــدرس", "المجمـــــوعة", "المقدم", "الباقى")
    sh.Range("A2").Resize(dic.Count, 4).Value = Application.Transpose(Application.Transpose(dic.items))
    '--------------------------------------------------------------------------------
'هذا الجزء تم اضافتة للكود لازالة الاصفار
'الموجودةاسفل اعمدة المقدم والباقي
'    lm = sh.Range("C" & Rows.Count).End(xlUp).Row
'   sh.Range("C" & lm).Select
'    Range(Selection, Selection.End(xlToRight)).Select
'    Selection.ClearContents
End Sub

صورة النتائج 

MjkzNDY0MQ3333Capture

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  سنتر_تعليمى.rar   تحميل rar مرات التحميل :(2)
الحجم :(58.098) KB


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



03-04-2020 12:04 صباحا
مشاهدة مشاركة منفردة [5]
ابراهيم الحداد
menu_open
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 172
الجنس : ذكر
الدعوات : 1
يتابعهم : 0
يتابعونه : 28
قوة السمعة : 1443
الاعجاب : 44
 offline 
look/images/icons/i1.gif استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس
السلام عليكم ورحمة الله
يمكنك استخدام الكود التالى بدون توسيط الكائن قاموس
Sub CenterAccts()
Dim ws As Worksheet, Sh As Worksheet
Dim C As Range, y As Long, z As Long
Dim Arr As Variant, Temp As Variant, yy As Long, zz As Long
Dim LR As Long, I As Long, p As Long, x As Integer, j As Integer
t = Timer
Application.ScreenUpdating = False
Set ws = Sheets("ayman")
Set Sh = Sheets("nour")
LR = ws.Range("B" & Rows.Count).End(xlUp).Row
Arr = ws.Range("A3:V" & LR)
ReDim Temp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))
For I = 1 To UBound(Arr, 1)
x = WorksheetFunction.CountIfs(ws.Range("D3:D" & I + 2), Arr(I, 4), _
ws.Range("E3:E" & I + 2), Arr(I, 5))
If x = 1 Then
p = p + 1
For j = 1 To 2
Temp(p, j) = Arr(I, Choose(j, 4, 5))
Next
End If
Next
If p > 0 Then Sh.Range("C2").Resize(p, 4) = Temp
For Each C In Sh.Range("C2:C" & Sh.Range("C" & Rows.Count).End(xlUp).Row)
S = C.Offset(0, 1)
y = WorksheetFunction.SumIfs(ws.Range("K2:K" & LR), _
ws.Range("D2:D" & LR), C, ws.Range("E2:E" & LR), S)
yy = WorksheetFunction.SumIfs(ws.Range("U2:U" & LR), _
ws.Range("N2:N" & LR), C, ws.Range("O2:O" & LR), S)

z = WorksheetFunction.SumIfs(ws.Range("L2:L" & LR), _
ws.Range("D2:D" & LR), C, ws.Range("E2:E" & LR), S)
zz = WorksheetFunction.SumIfs(ws.Range("V2:V" & LR), _
ws.Range("N2:N" & LR), C, ws.Range("O2:O" & LR), S)

C.Offset(0, 2) = y + yy
C.Offset(0, 3) = z + zz
Next
Application.ScreenUpdating = True
MsgBox Round(Timer - t, 2)
End Sub


أثارت هذه المشاركة إعجاب: YasserKhalil، ali mohamed ali، ayman_2000،



03-04-2020 06:41 صباحا
مشاهدة مشاركة منفردة [6]
ayman_2000
menu_open
عضو نشيط
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 04-09-2017
رقم العضوية : 337
المشاركات : 84
الجنس : ذكر
تاريخ الميلاد : 14-5-1963
يتابعهم : 3
يتابعونه : 2
قوة السمعة : 153
الاعجاب : 17
 offline 
look/images/icons/i1.gif استخراج القيم الغير مكررة من عمودين وجمع الإجمالي الخاص بيهم باستخدام كائن القاموس
اشكرك استاذى الفاضل ابراهيم الحداد على هذا الكود الرائع
نفعنا الله بعلمك ، وجعله في ميزان حسناتك 
تقبل تحياتي

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





المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
داله معرفه AlsqrRDup لجلب القيم الفريده الغير مكرره - حسام خطاب الصقر
63 5973 حمزة
استخراج القيم الغير مكررة (القيم الفريدة) سوزي كارم
17 2480 YasserKhalil

الكلمات الدلالية
استخراج ، القيم ، الغير ، مكررة ، عمودين ، وجمع ، الإجمالي ، الخاص ، بيهم ، باستخدام ، كائن ، القاموس ،


 








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

الساعة الآن 06:50 مساء

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