اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

تحويل دالة SUMIFS الى كود VBA

أبو ليمونه

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

 مشاركة
إذهب إلى أفضل إجابة Solved by عبدالله باقشير,

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

أبو ليمونه

أبو ليمونه

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

السلام عليكم ...

 

حاولت تحويل دالة SUMIFS الى VBA لكن وجدت انه من الصعب تحويلها ... لاني اعرف فقط اساسيات VBA ولم اتعمق فيها ...

 

لدي دالتين :

 

الدالة الاولى وهي :

=SUMIFS(Data1!$D$1:$D$50000, Data1!$A$1:$A$50000, $B$1, Data1!$B$1:$B$50000, "<="&A2, Data1!$C$1:$C$50000, "T")

وتم تطبيق هذه الدالة على الخلايا B2:E100

 

والدالة هذه الثاني هي :

=SUMIFS(Data2!$D$1:$D$50000, Data2!$A$1:$A$50000, $B$1, Data2!$B$1:$B$50000, "<="&A101, Data2!$C$1:$C$50000, "T")+$B$100

وتم تطبيق هذه الدالة على الخلايا B101:E199

 

سؤالي ... هل بالامكان تحويل الداتين اعلاها الى كود VBA  يعطي نفس النتيجية ويكون مرن وسريع باستخراج النتيجة المطلوبة ؟؟ ...

 

او هل بالامكان تحويل الدالتين الى PowerPivot او Power Query  حيث انني اتعامل مع كم هائل من البيانات ... حيث ان الداتا بيز احيانا قد تحتوي على 150000 صف 

 

مرفق لكم مثال ملف اكسل ...

 

شاكرا ومقدرا لكم مساعدتكم ...

Ex.xlsx.zip

أبو ليمونه

أبو ليمونه

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

السلام عليكم ...

 

شباب اتمنى منكم مشاركتي ارائكم .... ماهي افضل طريقة لاستخراج نتائج المعادلات اعلاه ...

 

جربت اطبق المعادلات اعلاه على خلايا اكثر ... لكن الاكسل يعلق ...

 

رئيكم ماهي افضل طريقة ؟ ...

 

شكرا لكم 

أبو ليمونه

أبو ليمونه

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

شكرا لك حمادة ...

 

اذا احد لدية الخبرة لكتابة كود احترافي يعمل مع الداتا بيز ... فليس لدي مانع ان ادفع له مبلغ من مال مقابل ذلك ... لاني اعتقد ان الموضوع قد ياخذ وقت لتحليل الداتا بيز وعمل كود

 

تحياتي لكم

الـعيدروس

الـعيدروس

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

السلام عليكم

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

Public Sub Ali_Smif()
'
For ii = 2 To 199
  Cells(ii, 2) = Sim_a(Range("A" & ii), [B1])
  Cells(ii, 3) = Sim_a(Range("A" & ii), [C1])
  Cells(ii, 4) = Sim_a(Range("A" & ii), [D1])
  Cells(ii, 5) = Sim_a(Range("A" & ii), [E1])
Next
'
End Sub
Private Function Sim_a(ByVal A As Range, B1 As Range)
On Error Resume Next
 Set Aa = ورقة2.[D1:D30000]
  Set Ab = ورقة2.[A1:A30000]
  Set Ad = ورقة2.[B1:B30000]
  Set Ag = ورقة2.[C1:C30000]
  Ch = "T"
  Sim_a = Application.SumIfs(Aa, Ab, B1, Ad, "<=" & A, Ag, Ch)
On Error GoTo 0
End Function
عبدالله باقشير

عبدالله باقشير

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

السلام عليكم

 

يتم استخراج البيانات لكل القيم الفريدة في العمود بي للورقة Data1

Option Explicit

Private Const ContColmn As Integer = 5
'======================================================
'======================================================

Sub kh_Report()
Dim obj As Object
Dim Ar() As Double, XX() As Double, X() As Double
Dim v As Double, vv As Double
Dim Rng As Range
Dim LastRow As Long, iCont As Long
Dim i As Long, ii As Long, iii As Long, R As Long
Dim C As Integer
Dim tx
''''''''''''''''''''''
On Error GoTo kh_ex

Set obj = CreateObject("Scripting.Dictionary")
'''''''''''''''''''''
'============================================
kh_Clear
'============================================
With æÑÞÉ2
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = .Range("A1:D" & LastRow)
End With

'============================================
ReDim Ar(1 To ContColmn - 1)
For C = 1 To ContColmn - 1
    Ar(C) = Range("B1").Cells(1, C).Value
Next
tx = Range("F1").Value
'============================================

kh_Application False

With Rng
    .Sort .Columns(2), xlAscending
    
    For i = 1 To .Rows.Count
        v = .Cells(i, "B").Value
        vv = Val(.Cells(i, "D"))
        If obj.Exists(v) Then
            iii = obj(v)
            ''''''''''''''''''
            If .Cells(i, "C").Value = tx Then
                For C = 1 To ContColmn - 1
                    If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = XX(C + 1, iii) + vv
                Next
            End If
        Else
            ii = ii + 1
            ReDim Preserve XX(1 To ContColmn, 1 To ii)
            obj.Add v, ii
            ''''''''''''''''''
            XX(1, ii) = v
            If .Cells(i, "C").Value = tx Then
                For C = 1 To ContColmn - 1
                    If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = vv
                Next
            End If
        End If
    Next
End With
'''''''''''''''''''''''''''''''
iCont = obj.Count
If iCont Then
    Erase Ar
    ReDim Ar(1 To ContColmn - 1)
    ReDim X(1 To iCont, 1 To ContColmn)
    
    For i = 1 To iCont
        X(i, 1) = XX(1, i)
        For C = 1 To ContColmn - 1
            Ar(C) = Ar(C) + XX(C + 1, i)
            X(i, C + 1) = Ar(C)
        Next
    Next
    
    With Range("A2").Resize(iCont, ContColmn)
        If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats
        .Value = X
    End With
    
    '''''''''''''''''''''''''
End If
'============================================

kh_ex:
kh_Application True
''''''''''''''''''
''''''''''''''''''
''''''''''''''''''

Set obj = Nothing
Set Rng = Nothing
Erase XX, X, Ar
''''''''''''''''''
If Err Then
    MsgBox "Err.Number : " & Err.Number
    Err.Clear
End If
End Sub

شاهد المرفق 2010

Ex1.rar

  • Like 2
  • Thanks 1
حمادة عمر

حمادة عمر

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

شكرا لك حمادة ...

 

اذا احد لدية الخبرة لكتابة كود احترافي يعمل مع الداتا بيز ... فليس لدي مانع ان ادفع له مبلغ من مال مقابل ذلك ... لاني اعتقد ان الموضوع قد ياخذ وقت لتحليل الداتا بيز وعمل كود

 

تحياتي لكم

 

بعد اذن الاساتذة الكبار

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

 

للعلم الجميع هنا اخي الكريم يقدمون يد العون بعضهم البعض

ابتغاء مرضاه الله فقط ...

ولكن كل يقدم ما لديه  بناء علي ما يسمح به وقته

واظنك رأيت ردود الكبيرين

الاستاذ / عباد ( العيدروس )

والاستاذ / عبد الله باقشير

اكواد في منتهي الرووعة والجمال ... دون مقابل ... كل ما يتنموه فقط ... هو ان تصل انت الي ما تريد

ارجو منك ان تتفهم وجهه نظري ... وهنيئا لك الاكواد الرائعة

تقبل خالص تحياتي

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

أبو ليمونه

أبو ليمونه

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

السلام عليكم ...

 

اخي حمادة والله اني ما اعرف كيف اشكرهم ... فعلا الاكواد تعمل بكل مرونة ... خصوصا ملف الاستاذ عبدالله باقشير....

 

وسبب عرضي للمبلغ المادي ... لثقتي ان هذه الاكواد راح تاخذ من وقتهم الكثير ... 

 

لكن ... اللهم وفقهم في دنياهم واخرتهم ... وارزقهم من فضلك العظيم ...

 

شكرا لكم جميعا ...

  • أفضل إجابة
عبدالله باقشير

عبدالله باقشير

قام بنشر
  • أفضل إجابة
قام بنشر

السلام عليكم

 

استدراك

هنا خطا غير مقصود في الكود في السطر

If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = vv

يجب تعديله الى

If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, ii) = vv

وهذا الكود بعد التعديل

Sub kh_Report()
Dim obj As Object
Dim Ar() As Double, XX() As Double, X() As Double
Dim v As Double, vv As Double
Dim Rng As Range
Dim LastRow As Long, iCont As Long
Dim i As Long, ii As Long, iii As Long, R As Long
Dim C As Integer
Dim tx
''''''''''''''''''''''
On Error GoTo kh_ex

Set obj = CreateObject("Scripting.Dictionary")
'''''''''''''''''''''
'============================================
kh_Clear
'============================================
With ورقة2
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    Set Rng = .Range("A1:D" & LastRow)
End With

'============================================
ReDim Ar(1 To ContColmn - 1)
For C = 1 To ContColmn - 1
    Ar(C) = Range("B1").Cells(1, C).Value
Next
tx = Range("F1").Value
'============================================

kh_Application False

With Rng
    .Sort .Columns(2), xlAscending
    
    For i = 1 To .Rows.Count
        v = .Cells(i, "B").Value
        vv = Val(.Cells(i, "D"))
        If obj.Exists(v) Then
            iii = obj(v)
            ''''''''''''''''''
            If .Cells(i, "C").Value = tx Then
                For C = 1 To ContColmn - 1
                    If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, iii) = XX(C + 1, iii) + vv
                Next
            End If
        Else
            ii = ii + 1
            ReDim Preserve XX(1 To ContColmn, 1 To ii)
            obj.Add v, ii
            ''''''''''''''''''
            XX(1, ii) = v
            If .Cells(i, "C").Value = tx Then
                For C = 1 To ContColmn - 1
                    If .Cells(i, "A").Value = Ar(C) Then XX(C + 1, ii) = vv
                Next
            End If
        End If
    Next
End With
'''''''''''''''''''''''''''''''
iCont = obj.Count
If iCont Then
    'Erase Ar
    ReDim Ar(1 To ContColmn - 1)
    ReDim X(1 To iCont, 1 To ContColmn)
    
    For i = 1 To iCont
        X(i, 1) = XX(1, i)
        For C = 1 To ContColmn - 1
            Ar(C) = Ar(C) + XX(C + 1, i)
            X(i, C + 1) = Ar(C)
        Next
    Next
    
    With Range("A2").Resize(iCont, ContColmn)
        If iCont > 1 Then .Rows(1).AutoFill .Cells, xlFillFormats
        .Value = X
    End With
    
    '''''''''''''''''''''''''
End If
'============================================

kh_ex:
kh_Application True
''''''''''''''''''
''''''''''''''''''
''''''''''''''''''

Set obj = Nothing
Set Rng = Nothing
Erase XX, X, Ar
''''''''''''''''''
If Err Then
    MsgBox "Err.Number : " & Err.Number
    Err.Clear
End If
End Sub

تحياتي

  • 3 months later...
زائر
هذا الموضوع مغلق.
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept