اذهب الي المحتوي
أوفيسنا

تعديل فى كود سحب بيانات من تقرير للأستاذ القدير / العيدروس

Yasser Fathi Albanna

بواسطه Yasser Fathi Albanna
في منتدى الاكسيل Excel

 مشاركة

الردود الموصى بها

Yasser Fathi Albanna

Yasser Fathi Albanna

قام بنشر
قام بنشر

السلام عليكم ورحمة الله وبركاته

إخوانى وأحبائى أعضاء وأساتذة ونجوم هذا الصرح العلمى العالمى العظيم

بعد التحية

قمت بطرح موضوع سابق من قبل طلبت فيه سحب بيانات معينة من تقرير لتقرير معين

وتفضل الأستاذ القدير الفاضل / العيدروس

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

الكود هو :

Function Ali(Ln As Long, Vl, Bl As String, Bln As Boolean)
Dim Shet As Worksheet
Dim Do_Ali
Dim Ar() As Variant
Dim iCnt&
Dim X, A
Set Shet = Sheets("Report")
Set Do_Ali = CreateObject("Scripting.Dictionary")
With Application
    .ScreenUpdating = False
    .EnableEvents = True
    DoEvents
With Shet
Lr = .Cells(.Rows.Count, 2).End(xlUp).Row
Ar = .Range("A2:F" & Lr).Value: A = Bl
For R = LBound(Ar, 1) To UBound(Ar, 1)
If Ar(R, 3) = A Then
If Not Bln Then X = IIf(Vl = 3, X + 1, IIf(Vl = 4, X + Ar(R, 6), X + 1))
If Do_Ali.exists(Ar(R, Ln)) Then
    Do_Ali.Item(Ar(R, Ln)) = Do_Ali.Item(Ar(R, Ln)) + 1
Else
    Do_Ali.Add Ar(R, Ln), 1
End If
End If
Next
Ali = IIf(Vl = 1, Do_Ali.Count, X)
End With
   .ScreenUpdating = True
   .EnableEvents = False
End With
Erase Ar
Set Do_Ali = Nothing
Set Shet = Nothing
End Function
Sub Ali_Count()
Dim Sh As Worksheet
Dim R, Rr, Cll
Set Sh = Sheets("Rank")
With Sh
Rr = 10: Cll = 13
For R = Rr To Cll
If .Cells(R, 2) <> "" Then
      .Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False)
        .Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False)
       .Cells(R, 14) = Ali(4, 1, .Cells(R, 2), True)
   .Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True)
End If
Next
End With
MsgBox "Greetings with Engineer / Yasser Fathi Al-Banna "
End Sub

 

وتفضل أيضا الأخ الحبيب أستاذى ومعلمى القدير / ياسر خليل بتعديل طفيف فى الكود لتسريعة وكانت أيضا نتيجته ممتاذة

والكود هو : 

Sub Test()
    Dim Coll As New Collection, CollDummy1 As New Collection, CollDummy2 As New Collection
    Dim ArrData, ArrIn, ArrOut1(), ArrOut2(), ArrOut3(), ArrOut4(), ArrCalc(), ArrTemp
    Dim I As Long, P As Long
    
    With Sheets("Report")
        ArrData = .Range("A2:F" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 2))
    End With
    
    With Sheets("Rank")
        ArrIn = .Range("B10:B" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 10))
    End With
    
    ReDim ArrOut1(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut2(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut3(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut4(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrCalc(1 To UBound(ArrData, 1), 1 To 2)
    
    On Error Resume Next
    For I = 1 To UBound(ArrData, 1)
        Set CollDummy1 = Nothing
        Set CollDummy2 = Nothing
        Coll.Add Key:=ArrData(I, 3), Item:=Array(Coll.Count + 1, CollDummy1, CollDummy2)
        ArrTemp = Coll(ArrData(I, 3))
        ArrTemp(1).Add Key:=ArrData(I, 4), Item:=Empty
        ArrTemp(2).Add Key:=ArrData(I, 1), Item:=Empty
        P = ArrTemp(0)
        ArrCalc(P, 1) = ArrCalc(P, 1) + ArrData(I, 6)
        ArrCalc(P, 2) = ArrCalc(P, 2) + 1
    Next I
    On Error GoTo 0
    
    For I = 1 To UBound(ArrIn, 1)
        On Error Resume Next
        ArrTemp = Coll(ArrIn(I, 1))
        If Err.Number = 0 Then
            ArrOut1(I, 1) = ArrCalc(ArrTemp(0), 1)
            ArrOut2(I, 1) = ArrCalc(ArrTemp(0), 2)
            ArrOut3(I, 1) = ArrTemp(1).Count
            ArrOut4(I, 1) = ArrTemp(2).Count
        End If
        On Error GoTo 0
    Next I
    
    Application.ScreenUpdating = False
        With Sheets("Rank")
            .Range("D10").Resize(UBound(ArrOut1, 1), 1).Value = ArrOut1
            .Range("I10").Resize(UBound(ArrOut2, 1), 1).Value = ArrOut2
            .Range("N10").Resize(UBound(ArrOut3, 1), 1).Value = ArrOut3
            .Range("S10").Resize(UBound(ArrOut4, 1), 1).Value = ArrOut4
        End With
    Application.ScreenUpdating = True
End Sub

الرجاء المساعدة ولكم خالص الشكر والتقدير

Rank.rar

ياسر خليل أبو البراء

ياسر خليل أبو البراء

قام بنشر
قام بنشر

أخي الحبيب ياسر فتحي

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

تقبل وافر تقديري واحترامي

  • Like 1
Yasser Fathi Albanna

Yasser Fathi Albanna

قام بنشر
  • الكاتب
قام بنشر

حبيبى الغالى أستاذى ومعلمى القدير / ياسر خليل

الذى مجرد مرورة على موضوع لى شرف لى

الطلب واضح أخى الحبيب فى المرفق وسأوضحة ثانية

يوجد بالملف المرفق تقرير سيستم وبجوارة Rank قمت بتصميمة به ثلاثة خانات

الخانة الأولى و هى To وهى عبارة عن إجمالى مبيعات المندوب  وهى تعمل بكفائة عن طريق الكود الذى تفضل الأستاذ القدير / العيدروس بصياغته لى

الخانة الثانية وهى P C وهى عبارة عن الزيارات الإجابية التى يحققها المندوب وهى الخانة المراد بها التعديل داخل الكود الذى تفضل الأستاذ القدير بصياغته لى لتعطى النتيجة الأتية وهى

( وهى أننى أريد وضع العميل فقط فى هذه الخانة حسب التاريخ أى أن العميل فرضا لو إسمه ياسر وسحب يوم 01/11/2015 وسحب فى نفس اليوم 50 مرة يعد مرة واحدة فقط وإذا سحب يوم 02/11/2015 مرة ثانية وأيضا تكرر فى نفس اليوم 50 مرة أيضا يحسب مرة واحد يبقى إجمالى اليومين 2 فقط زيارة إجابية وموضح بالمرفق النتيجة المطلوبة )

الخانة الثالثة وهى LPC وهى عبارة عن الأصناف المباعة للمندوب حتى ولم مكررة وهى مضبوطة داخل الكود الذى تفضل به الأستاذ القدير / العيدروس بصياغته لى

الخانة الرابعة وهى EC وهى عبارة عن عدد العملاء المتعاملين مع المندوب بدون تكرار والنتيجة مضبوطة أيضا داخل الكود الذى تفضل به الأستاذ القدير / العيدروس بصياغته لى

وشكرا

مرفق التقرير والرانك وموضح به النتائج المطلوبة

 

Rank.rar

Yasser Fathi Albanna

Yasser Fathi Albanna

قام بنشر
  • الكاتب
قام بنشر

السيد الأستاذ الفاضل / ياسر خليل

هل يوجد إمكانية فى تعديل الكود الخاص بالأستاذ الفاضل / العيدروس

الذى تفضلت حضرتك وقمت بالتعديل علية لينفذ العملية بسرعة ليقوم بالنتيجة المطلوبة فى المرفق عالية

ولسيادتكم خالص الشكر والتقدير

وشكرا لمجهود حضرتك وضياع وقتكم الثمين

والكود هو 

Sub Test()
    Dim Coll As New Collection, CollDummy1 As New Collection, CollDummy2 As New Collection
    Dim ArrData, ArrIn, ArrOut1(), ArrOut2(), ArrOut3(), ArrOut4(), ArrCalc(), ArrTemp
    Dim I As Long, P As Long
    
    With Sheets("Report")
        ArrData = .Range("A2:F" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 2))
    End With
    
    With Sheets("Rank")
        ArrIn = .Range("B10:B" & Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, 10))
    End With
    
    ReDim ArrOut1(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut2(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut3(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrOut4(1 To UBound(ArrIn, 1), 1 To 1)
    ReDim ArrCalc(1 To UBound(ArrData, 1), 1 To 2)
    
    On Error Resume Next
    For I = 1 To UBound(ArrData, 1)
        Set CollDummy1 = Nothing
        Set CollDummy2 = Nothing
        Coll.Add Key:=ArrData(I, 3), Item:=Array(Coll.Count + 1, CollDummy1, CollDummy2)
        ArrTemp = Coll(ArrData(I, 3))
        ArrTemp(1).Add Key:=ArrData(I, 4), Item:=Empty
        ArrTemp(2).Add Key:=ArrData(I, 1), Item:=Empty
        P = ArrTemp(0)
        ArrCalc(P, 1) = ArrCalc(P, 1) + ArrData(I, 6)
        ArrCalc(P, 2) = ArrCalc(P, 2) + 1
    Next I
    On Error GoTo 0
    
    For I = 1 To UBound(ArrIn, 1)
        On Error Resume Next
        ArrTemp = Coll(ArrIn(I, 1))
        If Err.Number = 0 Then
            ArrOut1(I, 1) = ArrCalc(ArrTemp(0), 1)
            ArrOut2(I, 1) = ArrCalc(ArrTemp(0), 2)
            ArrOut3(I, 1) = ArrTemp(1).Count
            ArrOut4(I, 1) = ArrTemp(2).Count
        End If
        On Error GoTo 0
    Next I
    
    Application.ScreenUpdating = False
        With Sheets("Rank")
            .Range("D10").Resize(UBound(ArrOut1, 1), 1).Value = ArrOut1
            .Range("I10").Resize(UBound(ArrOut2, 1), 1).Value = ArrOut2
            .Range("N10").Resize(UBound(ArrOut3, 1), 1).Value = ArrOut3
            .Range("S10").Resize(UBound(ArrOut4, 1), 1).Value = ArrOut4
        End With
    Application.ScreenUpdating = True
End Sub

 

الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

السلام عليكم 

اخي الكريم ياسر فتحي

الصبر الصبر ان شاء الله خير

رغم قراءتي لطلبك سابقاً الا اني لم اوفق

لفكرهعمليه تخدم ملفك السبب كبر حجم البيانات

 ان شاء الله لي محاوله ان وفقت سوف ارفقه

تحياتي

  • Like 2
Yasser Fathi Albanna

Yasser Fathi Albanna

قام بنشر
  • الكاتب
قام بنشر
11 ساعات مضت, الـعيدروس said:

السلام عليكم 

اخي الكريم ياسر فتحي

الصبر الصبر ان شاء الله خير

رغم قراءتي لطلبك سابقاً الا اني لم اوفق

لفكرهعمليه تخدم ملفك السبب كبر حجم البيانات

 ان شاء الله لي محاوله ان وفقت سوف ارفقه

تحياتي

أستاذى ومعلمى القدير / العيدروس

شاكر جدا جدا لمجهود حضرتك الرائع وتعبك معايا

وأسف جدا جدا لكثرة البيانات فكل التقارير المسحوبة من السيستم بهذا الشكل

وطلبى لهذه الأكواد هو سهولة تحليل الداتا بشكل سريع

وليتنى أتعلم من سيادتكم كيفية عمل مثل هذه الأكواد وطريقة شرح عملها لأن معظم تعاملى مع التقارير

تتطلب منى عمل مثل هذه الأكواد لسحب بيانات معينة لسهولة التعامل

مرة ثانية أشكر حضرتك جدا جدا

جزاك الله خير وأدام عليك الصحة والعافية وزادك من العلم الكثير والكثير

ملحوظة المرفق به تقرير مخفف وليس كامل الداتا لسهولة رفعة على المنتدى والتجربة علية

الـعيدروس

الـعيدروس

قام بنشر
قام بنشر

جرب هذا التعديل على ملف الداتا الكامل

على ملفك المرفق المختصر يعطي نتائج سليمه  

Private Function Ali(Ln As Long, Vl, Bl As String, Bln As Boolean)
Dim Shet As Worksheet
Dim Do_Ali
Dim Ar() As Variant
Dim iCnt&
Dim X, A
On Error Resume Next
Set Shet = Sheets("Report")
Set Do_Ali = CreateObject("Scripting.Dictionary")
With Application
    .ScreenUpdating = False
    .EnableEvents = True
    DoEvents
With Shet
Lr = .Cells(.Rows.Count, 2).End(xlUp).Row
Ar = .Range("A2:F" & Lr).Value: A = Bl
For R = LBound(Ar, 1) To UBound(Ar, 1)
If Ar(R, 3) = A Then
If Not Bln Then
If Vl = 3 Then
ZZ = Ar(R, 2): ZZZ = Ar(R - 1, 2)
If ZZZ <> ZZ Then
   X = X + 1
End If
End If
If Vl = 4 Then
    X = X + Ar(R, 6)
End If
End If
If Do_Ali.exists(Ar(R, Ln)) Then
    Do_Ali.Item(Ar(R, Ln)) = Do_Ali.Item(Ar(R, Ln)) + 1
Else
    Do_Ali.Add Ar(R, Ln), 1
End If
End If
Next
Ali = IIf(Vl = 1, Do_Ali.Count, X)
End With
   .ScreenUpdating = True
   .EnableEvents = False
End With
Erase Ar
Set Do_Ali = Nothing
Set Shet = Nothing
End Function
Sub Ali_Count()
Dim Sh As Worksheet
Dim Sht As Worksheet
Dim R, Rr, Cll, Lrr
Set Sh = Sheets("Rank")
Set Sht = Sheets("Report")
With Sh
Lrr = Sht.Cells(Rows.Count, 2).End(xlUp).Row
Sht.Sort.SortFields.Add Key:=Sht.Range("A2:A" & Lrr), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With Sht.Sort
        .SetRange Sht.Range("A1:F" & Lrr)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
End With
Rr = 10: Cll = 13
For R = Rr To Cll
If .Cells(R, 2) <> "" Then
      .Cells(R, 4) = Ali(1, 4, .Cells(R, 2), False)
        .Cells(R, 9) = Ali(1, 3, .Cells(R, 2), False)
       .Cells(R, 14) = Ali(4, 1, .Cells(R, 2), True)
   .Cells(R, 19) = Ali(1, 1, .Cells(R, 2), True)
End If
Next
End With
MsgBox "Greetings with Engineer / Yasser Fathi Al-Banna "
End Sub

 

  • Like 1
Yasser Fathi Albanna

Yasser Fathi Albanna

قام بنشر
  • الكاتب
قام بنشر

أستاذى وعلمى القدير / العيدروس

فى البداية سلمت يمينك وأدام الله عليك الصحة والعافية وجزاك الله خير الجزاء على مجهودك العظيم

بصراحة أنا مش عارف أشكر حضرتك إزاى بس كل إللى أنا عايز أقولة

بجد سلمت يمينك للمرة الثانية هذا هو المطلوب بالضبط

تقبل خالص تحياتى وتقديرى وإحترامى

  • Like 1

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع
×
×
  • اضف...

Important Information

  I accept