كود برمجى لسحب داتا من تقرير

[Yasser Fathi Albanna]

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

إخوانى وأحبائى الأعزاء أستاذتى وأعضاء هذا المنتدى العظيم

تحية طيبة ووبعد

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

الرجاء من سيادتكم النظر إلى الرابط التالى وبه المرفق وعزرا لعدم إرفاقه بالمنتدى لكبر حجمه

أريد من سيادتكم كود برمجى ينفذ المطلوب بالمرفق

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

http://www.4shared.com/rar/iABxXqB0ce/Report.html

 

 

 

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

أخي الغالي ياسر

الملف غير موجود

Sorry, the file link that you requested is not valid. Sign error.

يرجى حذف البيانات والإبقاء على 20 صف من البيانات فقط كمثال .. حتى يسهل عليك رفع الملف ..

هذا أفضل وأيسر كما يرجى وضع شكل النتائج المتوقعة

تقبل تحياتي

[Yasser Fathi Albanna]

اخى الحبيب الغالى أ / ياسر خليل

دايما تاعبك معايا

مرفق رابط أخر وموضح به النتائج المتوقعة

http://www.mediafire.com/download/xjfce1kxlw9lzzu/Report.rar

 

 

 

[الـعيدروس]

السلام عليكم

جرب الكود التالي

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
Set Sh = Sheets("Rank")
For R = 10 To 28
With Sh
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
End With
Next
Set Sh = Nothing
End Sub

 

[Yasser Fathi Albanna]

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

هذا هو المطلوب بالضبط

ألف ألف شكر لمجهود حضرتك العظيم جزاك الله كل الخير وأدام عليك الصحة والعافية

وزادك الله من العلم الكثير والكثير

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

[Yasser Fathi Albanna]

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

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

وتفضل الأستاذ القدير الحبيب / ياسر خليل بهذا الكود

Sub ClearConstants()
  Dim Rng As Range, Arr, I As Long, J As Long

  With Sheets("Rank")
    Set Rng = .Range("A9:S28")
    Arr = Rng.Formula
  End With

  For I = 1 To UBound(Arr, 1)
      If IsNumeric(Arr(I, 1)) Then
         For J = 4 To 19 Step 3
             Arr(I, J) = ""
         Next J
      End If
  Next I
End Sub

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

ولم أفلح

فأين الخطأ ولسيادتكم خالص الشكر والتقدير

ولى طلب أخر هل يمكن إضافة رسالة ترحيب مثل ( تم بحمد الله ) فى الكود الأول

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
Set Sh = Sheets("Rank")
For R = 10 To 28
With Sh
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
End With
Next
Set Sh = Nothing
End Sub

 

[الـعيدروس]

هذا للمسح الداتا المنقوله 

Sub ClearConstants_1()
Dim Sh As Worksheet
Dim Rr, Cll
Set Sh = Sheets("Rank")
With Sh
Rr = 10: Cll = 28
 Union(.Range(Cells(Rr, 4), Cells(Cll, 4)), .Range(Cells(Rr, 9), Cells(Cll, 9)), _
.Range(Cells(Rr, 14), Cells(Cll, 14)), .Range(Cells(Rr, 19), Cells(Cll, 19))).ClearContents
End With
End Sub

والرساله استبدل الكود المسمى  Ali_Count بالتالي

او انسخ هات الى اخر الكود قبل End Sub

MsgBox "تم بحمد الله ", vbInformation, "تمت العمليه"

 

 

Sub Ali_Count()
Dim Sh As Worksheet
Dim R, Rr, Cll
Set Sh = Sheets("Rank")
With Sh
Rr = 10: Cll = 28
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 "تم بحمد الله ", vbInformation, "تمت العمليه"
Set Sh = Nothing
End Sub

 

تم تعديل نوفمبر 3, 2015 بواسطه الـعيدروس

[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

تقبلوا تحياتي

[Yasser Fathi Albanna]

اخى الحبيب الغالى الذى أكن له كل ود وإحترام الأستاذ القدير / ياسر خليل

سلمت يمينك وزادك من الله العلم الكثير

الكود ممتاذ وسريع

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

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

على مجهوده الرائع وعلى أكواده الرائعة

جزاه الله خيرا

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

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

يعلم الله أني لم أكن أنوي إرفاق الحل ولكن خشيت أن أكون ممكن يكتم العلم

وفي النهاية ليس من صاغ وألف وأبدع (أقصد أخي وحبيبي في الله العيدروس) ..كمن نقل وفقط (أقصدني) ..

شتان بيننا .. فوالله الذي لا إله إلا هو إني أحب أخي علي في الله حباً شديداً

وما أرفقت الحل الأخير إلا لكونه ينجز عملك بشكل أفضل ، ولكن إن رأيت أنه لا فرق في توقيتات الكود ما كنت لأرفقه احتراماً لمعلمي

تقبل تحياتي

[Yasser Fathi Albanna]

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

جزاه الله كل الخير

وشكرا لك أخى الحبيب / ياسر على إهتمامك بتسهيل الأمور على

جزاك الله خيرا

[saad abed]

اخوانى

مدرسة اكواد في نفس الوقت مدرسه اخلاق

نتعلم منها الحب في الله

وانا اشهد الله انى احب ابونصار واخى ياسر خليل حبا خالصا في الله

اساتذه في العلم والبرمجه واساتذه في التعامل مع الاخر

وفقكم الله

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

أخي الغالي سعد عابد

أحبك الله الذي أحببتنا فيه .. جزيت خيراً على مرورك العطر بالموضوع وفي انتظار مساهماتك وإبداعاتك (لا تتأخر علينا)

[الـعيدروس]

السلام عليكم

الاخ الحبيب ياسر خليل لازلنا في بداية الطريق

تعدد الحلول يثري الموضوع ويكسب القارئ معرفه جزيت كل خير

اخي الحبيب سعد عابد اسعد الله مساك

يشهد الله ان المعزه متبادله احبك الله الذي احببتنا فيه

 اسعدني مرورك العطر

تقبلو تحياتي وشكري