تسريع كود نقل بيانات

**Yasser Fathi Albanna** · يونيو 13, 2015

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

وكل عام وحضراتكم بخير وصحة وسعاده

أعاده الله عليكم بالخير واليمن والبركات

لقد طرحت موضوع من قبل وهو عبارة عن نقل بيانات من داتا تقرير بيعى إلى شيت مصمم من قبلى

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

أ / ياسر خليل

ممكن التفضل بجعل الكود الأتى يقوم بنفس المهام ولكن يكون سريع

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

مع وافر التحية

الكود

Sub SUMIFSVBA()
    Dim Cell As Range
    Dim LR As Long
    Dim rngNetValue As Range
    Dim rngNames As Range
    Dim rngGroup As Range
    Dim X As Double, Y
    Dim ICol As Long
    
    LR = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Set rngNetValue = Sheet1.Range("F2:F" & LR)
    Set rngNames = Sheet1.Range("L2:L" & LR)
    Set rngGroup = Sheet1.Range("C2:C" & LR)
    
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
        On Error Resume Next
        For ICol = 5 To 137 Step 3
            For Each Cell In Sheet2.Range("A6:A49")
                If IsNumeric(Cell) Then
                    Y = Application.WorksheetFunction.Index(Rows(4), 1, Cell.Offset(, ICol - 1).Column - 1)
                    X = Application.WorksheetFunction.SumIfs(rngNetValue, rngNames, Cell.Offset(, 1), rngGroup, Y)
                    Cell.Offset(, ICol - 1).Value = X
                End If
            Next Cell
        Next ICol
    MsgBox "تم بحمد الله"
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

تم تعديل يونيو 13, 2015 بواسطه Eng : Yasser Fathi Albanna

**Yasser Fathi Albanna** · يونيو 13, 2015

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

لعل المانع خير لعدم تواجدك بالمنتدى منذ يومين

ربنا يطمنا على حضرتك

**مختار حسين محمود** · يونيو 15, 2015

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

أُطمئنك على أخونا الأستاذ ياسر خليل

هو بخير والحمد لله و يقضى أجازة صغيرة عند الأهل

كل سنة وأنت طيب . أنت وكل الزملاء

**Yasser Fathi Albanna** · يونيو 15, 2015

الأخ العزيز الغالى / مختار

فى البداية كل سنة وحضرتك بخير وصحة وسعادة

وشكرا لك على إنك طمنتنى على العزيز الغالى الأستاذ القدير / ياسر خليل

وأجاذة سعيدة له

ياسر خليل أبو البراء · يونيو 21, 2015

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

أعتذر عن قلة المشاركات في هذه الأيام

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

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

**Yasser Fathi Albanna** · يونيو 21, 2015

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

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

نظرا لكبر مساحة الملف سوف أقوم برفعة على رابط خارجى

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

الشيت يوضح مثال لمندوب بعينه تم إختيارة من المندوبين وأمامه الشركات وأهداف كل شركة على حدا

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

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

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

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

رابط الملف

http://www.mediafire.com/download/9tlxd6ueehtab3k/Sales+Report+Achievement.rar

**Yasser Fathi Albanna** · يونيو 22, 2015

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

**Yasser Fathi Albanna** · يونيو 22, 2015

السادة الأفاضل

هل لا يوجد طريقة لعمل الكود الموضع بسرعة

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

هل يوجد طريقة لتسريع عمله

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

ياسر خليل أبو البراء · يونيو 23, 2015

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

كل عام وأنت بخير

إليك الكود التالي لعله يفي بالغرض (طبعاً الكود مش كودي عشان متقولش اشرحه )

Sub SUMIFSVBA()
  Dim Rng As Range, arrNet, arrName, arrGroup, arrOutput, Coll As New Collection
  Dim I As Long, J As Long, E As Long, P As Long, str1 As String

  With Sheets("Sales Report")
    arrNet = Intersect(.Columns("F"), .UsedRange).Value
    arrName = Intersect(.Columns("L"), .UsedRange).Value
    arrGroup = Intersect(.Columns("C"), .UsedRange).Value
  End With

  With Sheets("Achievement")
    Set Rng = .Range("A4:EH50")
    arrOutput = Rng.Formula
  End With

  For I = 2 To UBound(arrNet, 1)
      str1 = arrName(I, 1) & Chr(2) & arrGroup(I, 1)
      On Error Resume Next
         Coll.Add Key:=str1, Item:=Coll.Count + 1
         E = Err.Number
      On Error GoTo 0
      P = Coll(str1)
      If E = 0 Then
         arrNet(P, 1) = Val(arrNet(I, 1))
      Else
         arrNet(P, 1) = arrNet(P, 1) + Val(arrNet(I, 1))
      End If
  Next I

  For I = 1 To UBound(arrOutput, 1)
      If IsNumeric(arrOutput(I, 1)) Then
         For J = 5 To 137 Step 3
             On Error Resume Next
                P = Coll(arrOutput(I, 2) & Chr(2) & arrOutput(1, J - 1))
                E = Err.Number
             On Error GoTo 0
             If E = 0 Then
                arrOutput(I, J) = arrNet(P, 1)
             Else
                arrOutput(I, J) = 0
             End If
         Next J
      End If
  Next I

  Rng.Formula = arrOutput
End Sub

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

  With Sheets("Achievement")
    Set Rng = .Range("A4:EH50")
    Arr = Rng.Formula
  End With

  For I = 1 To UBound(Arr, 1)
      If IsNumeric(Arr(I, 1)) Then
         For J = 5 To 137 Step 3
             Arr(I, J) = ""
         Next J
      End If
  Next I

  Rng.Formula = Arr
End Sub

إن شاء الله يفي بالغرض

**Yasser Fathi Albanna** · يونيو 23, 2015

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

كل عام وأنت بخير

إليك الكود التالي لعله يفي بالغرض (طبعاً الكود مش كودي عشان متقولش اشرحه )

Sub SUMIFSVBA()
  Dim Rng As Range, arrNet, arrName, arrGroup, arrOutput, Coll As New Collection
  Dim I As Long, J As Long, E As Long, P As Long, str1 As String

  With Sheets("Sales Report")
    arrNet = Intersect(.Columns("F"), .UsedRange).Value
    arrName = Intersect(.Columns("L"), .UsedRange).Value
    arrGroup = Intersect(.Columns("C"), .UsedRange).Value
  End With

  With Sheets("Achievement")
    Set Rng = .Range("A4:EH50")
    arrOutput = Rng.Formula
  End With

  For I = 2 To UBound(arrNet, 1)
      str1 = arrName(I, 1) & Chr(2) & arrGroup(I, 1)
      On Error Resume Next
         Coll.Add Key:=str1, Item:=Coll.Count + 1
         E = Err.Number
      On Error GoTo 0
      P = Coll(str1)
      If E = 0 Then
         arrNet(P, 1) = Val(arrNet(I, 1))
      Else
         arrNet(P, 1) = arrNet(P, 1) + Val(arrNet(I, 1))
      End If
  Next I

  For I = 1 To UBound(arrOutput, 1)
      If IsNumeric(arrOutput(I, 1)) Then
         For J = 5 To 137 Step 3
             On Error Resume Next
                P = Coll(arrOutput(I, 2) & Chr(2) & arrOutput(1, J - 1))
                E = Err.Number
             On Error GoTo 0
             If E = 0 Then
                arrOutput(I, J) = arrNet(P, 1)
             Else
                arrOutput(I, J) = 0
             End If
         Next J
      End If
  Next I

  Rng.Formula = arrOutput
End Sub

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

  With Sheets("Achievement")
    Set Rng = .Range("A4:EH50")
    Arr = Rng.Formula
  End With

  For I = 1 To UBound(Arr, 1)
      If IsNumeric(Arr(I, 1)) Then
         For J = 5 To 137 Step 3
             Arr(I, J) = ""
         Next J
      End If
  Next I

  Rng.Formula = Arr
End Sub

إن شاء الله يفي بالغرض

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

كل شكرى وتقديرى وإحترامى لا يعطيك حقك

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

وكل سنة وحضرتك بألف صحة وسلامة

أعاده الله عليك بالخير واليمن البركات

ياسر خليل أبو البراء · يونيو 23, 2015

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

الحمد لله أن تم المطلوب على خير وكل عام وأنت بخير .. وجزيت خيراً على كلماتك الرقيقة

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

صوماً مقبولاً وإفطاراً شهياً ودعوة مقبولة بإذن الله

تقبل تحياتي

محمد لطفى · يوليو 25, 2015

حبيب قلبى جزاك الله خيرا

تسجيل الدخول

تسريع كود نقل بيانات

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

Yasser Fathi Albanna

Yasser Fathi Albanna

مختار حسين محمود

Yasser Fathi Albanna

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

Yasser Fathi Albanna

Yasser Fathi Albanna

Yasser Fathi Albanna

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

Yasser Fathi Albanna

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

محمد لطفى

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information