تحويل دالة SUMPRODUCT إلى كود VBA

[Eid Mostafa]

_{الأخوة الأعزاء}

_{السلام عليكم ورحمة الله وبركاته ،،،،}

_{هل بالإمكان تحويل دالة SUMPRODUCT بالملف المرفق إلى كود VBA ؟؟؟؟}

_{ولكم خالص تحياتى}

_أخوكم

_{عيد مصطفى}

Statement of Account (21.12.11).rar

[الـعيدروس]

السلام عليكم

جرب هكذا

Public Sub alidroos_CP_SU()

For ALI_SUM = 3 To 28

    Cells(17, ALI_SUM).Value = Evaluate("=SUMPRODUCT((Name=$B$17)*(Month=" & Cells(1, ALI_SUM).Address(False, True) & ")*Madine)")

Next ALI_SUM

End Sub

[Eid Mostafa]

_{الأخ الكريم}

_{بداية أشكرك بالغ الشكر على إهتمامك بالرد}

_{وقد قمت بتجربة الكود الذى أرسلته إلى ، ولكنه لم يؤدى المطلوب.}

_{حيث ستجد فى الملف المرفق بأننى قد قمت بعمل قيدين على سبيل التجربة}

_{القيد الأول بشيت [Movement] بسطر 356 ، 357 ويخص الحساب رقم 12 والحساب رقم 14 بتاريخ 2011/4/1}

_{القيد الثانى بشيت [Movement] بسطر 358 ، 359 ويخص نفس الحسابان أعلاه وبتاريخ 2011/5/1}

_{وبالذهاب إلى شيت [Detailed Trial Balance] لم أجد أن القيم بالقيدين أعلاه قد تم ترحيلهم.}

_{والمطلوب يتلخص فى التالى:-}

_{ترحيل القيم بالقيدين أعلاه إلى شيت [Detailed Trial Balance] التى تخص كل حساب أمام الحساب الخاص بها وفى الشهر الخاص بها}

_{بمعنى أوضح :-}

_{(ترحيل 99.999 إلى خانة K15 وأيضاً إلى خانة L17 وذلك بالنسبة للقيد الأول)}

_{(ترحيل 99.999 إلى خانة M15 وأيضاً إلى خانة N17 وذلك بالنسبة للقيد الثانى)}

_{أرجو أن أكون بذلك قد أوضحت لك ما أقصدة.}

_{وأرجو أيضاً ألا أكون قد أطلت عليك.}

_{ومرة أخرى لك خالص تحياتى وتقديرى.}

_أخوك

_{عيد مصطفى}

Statement of Account (24.12.11).rar

[الـعيدروس]

الاخ الفاضل عيد مصطفى

انت طلبت تحويل المعادلة الى كود

وانا اطلعت على المرفق للمشاركة السابقة

ووجود المعادلة هو في المدى ( C17 : AB17 ) فقط

والكود يقوم مقام الصيغة التي في المدى المذكور

ارجو ارفاق الصيغة المراد تحويلها الى كود

والسلام عليكم

تم تعديل ديسمبر 24, 2011 بواسطه alidroos

[الـعيدروس]

وهذا لتأكيد عمل الكود

جرب هذا نفس الكود ولاكن ينفذ الصيغة على المدى

Public Sub alidroos_CP_SU_F()

With ورقة1

    For ALI_SUM = 3 To 28

	    .Cells(17, ALI_SUM).Formula = "=SUMPRODUCT((Name=$B$17)*(Month=" & .Cells(1, ALI_SUM).Address(True, False) & ")*Madine)"

    Next ALI_SUM

End With

End Sub

[Eid Mostafa]

_{الأخ الكريم / العيدروس}

_{أكرر شكرى مرة أخرى على إهتمامك بالرد}

_{وعذراً على عدم الإيضاح ، فالمعادلة الموجودة بالمدى الذى ذكرتة هى كانت على سبيل المثال وقبل سحبها على كافة الحسابات (مرفق الملف بعد سحب المعادلة إلى المدى المطلوب ، وأرجو ألا تعانى مما أعانى منه فى بطء الجهاز وهو السبب الأول والأخير لطلبى تعديل المعادلة إلى كود).}

_{والمدى المطلوب هو من (C4 إلى AB160)}

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

_{أرجو أن أكون بذلك قد أوضحت لك ما أقصدة.}

_{وأرجو أيضاً ألا أكون قد أطلت عليك.}

_{ومرة أخرى لك خالص تحياتى وتقديرى.}

_أخوك

_{عيد مصطفى}

Statement of Account (24.12.11) 2.rar

[الـعيدروس]

السلام عليكم

حاولت اطبق الكود على عمود فأخذ وقت

فما بالك بالمدى كامل حقيقة ماانصحك

حاول تقلص من حجم الملف

لان حجم الملف ماهو طبيعي

تحياتي

[عبدالله المجرب]

السلام عليكم

الاستاذ الفاضل ابو نصار جهد ونشاط ملحوظ تشكر عليه وان شاء الله في موازين اعمالك

==

اخي الفاضل عيد مصطفى

ان شاء الله هذا الرابط ينفع معاك

http://www.officena.net/ib/index.php?showtopic=32650

[Eid Mostafa]

_{الأخ العزيز والفاضل / عبد الله}

_{أشكرك بالغ الشكر على إهتمامك بالرد.}

_{ولكن بالإطلاع على الملف الموجود بالرابط الذى أشرت إلية لم أجد أنه يتناسب مع طلبى.}

_{والذى يتمثل فى ترحيل قيم كل قيد إلى النطاق C4 : AB160 وفقاً للإعتبارات التالية:-}

_{- الشهر}

_{- إسم الحساب}

_{- طبيعة القيمة (مدينة / دائنة)}

_{أرجو منك التكرم والإطلاع على الملف المرفق بالمشاركة رقم 8 وما بها من شرح فقد تصل إلى حل لما أريدة.}

_أخوك

_{عيد مصطفى}

[بن علية حاجي]

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

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

أخوك بن علية

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

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

اخي الفاضل

نفس الحاصل الذي اورده اخي بن عليه

الملف ثقيل عند التنفيذ

جرب الكود التالي على عشرين صف زي ما هو معمول

اذا ناسبك زيادة النطاق الخاص بيك

Option Explicit


Sub kh_Evaluate()

Dim X As Boolean

Dim Rng As Range, Col As Range

Set Rng = Sheets("Detailed Trial Balance").Range("C4:AB20")

Rng.ClearContents

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual


For Each Col In Rng

    X = Col.Column Mod 2 = 1

    Select Case X

        Case True: Col = Application.Evaluate("=SUMPRODUCT((Name=" & Cells(Col.Row, 2).Address & ")*(Month=" & Cells(1, Col.Column).Address & ")*Madine)")

        Case False: Col = Application.Evaluate("=SUMPRODUCT((Name=" & Cells(Col.Row, 2).Address & ")*(Month=" & Cells(1, Col.Column).Address & ")*Daine)")

    End Select

Next

Application.Calculation = xlCalculationAutomatic

Application.ScreenUpdating = True

Set Rng = Nothing

End Sub

ودمتم في حفظ الله

[abouelhassan]

كل الاحترام وكل التقدير

استاذ عبدالله المجرب

استاذ بن علية

استاذ خبور خير

استاذ ابو نصار

كل وفائق الاحترام من كل قلبى

تم تعديل ديسمبر 25, 2011 بواسطه abouelhssan

[Eid Mostafa]

الأساتذة العظام

أستاذ عبدالله المجرب

أستاذ بن علية

أستاذ خبور خير

أستاذ أبو نصار

لقد قمت بإضافة الكود المعد بواسطة الأستاذ / خبور خير ، ثم قمت بعمل قيد على سبيل التجربة بشيت Movement ثم ذهبت لشيت Detailed Trial Balance فلم أجد شيئاً تم ترحيلة.

مرفق الملف للإطلاع.

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

أخوكم

عيد مصطفى

Statement of Account (24.12.11) 3.rar

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

السلام عليكم

هذا الكود للتجربة

قم بتنفيذه من الشبت Detailed Trial Balance

وعاين النتائج في النطاق "C4:AB20"

[Eid Mostafa]

^{السلام عليكم}

^{أخى الكريم / خبور خير}

^{لقد قمت بإضافة الكود إلى شيت Detailed Trial Balance ، ثم قمت بعمل قيد على سبيل التجربة بشيت Movement ثم ذهبت لشيت Detailed Trial Balance فلم أجد شيئاً تم ترحيلة.}

^{مرفق الملف للإطلاع بالمشاركة السابقة.}

^{خالص تحياتى وتقديرى}

^أخوك

^{عيد مصطفى}

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

السلام عليكم

اضغط الزر اللي امامك في المرفق

Statement of Account (24.12.11) 2.rar

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

السلام عليكم

لقد لاحظت الان النطاقات المسماه اللي موجودة في الدالة

تحتوي على 100000 صف

هذا سبب الثقل !!!!!

الاسم والشهر والمين او الدائن

300000 للمعادلة الوحدة

[بن علية حاجي]

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

إخواني الكرام، لما رأيت مشاركات أخي الحبيب خبور حفظه الله من كل سوء سعدت كثيرا وسيتم حل المسألة بإذن الله... والكود (ويبقى ثقيلا في التنفيذ) الذي كنت قد حضرته في هذا الشأن يشبه كثيرا كود أخي خبور ...

 

Sub hben()

  Application.ScreenUpdating = False

 For J = 3 To 28

    For I = 4 To 160

	  If J Mod 2 = 1 Then

		 Cells(I, J) = Evaluate("SumProduct(( Name = B" & I & ")*(Month =" & Cells(1, J) & ")* Madine)")

	  Else

		 Cells(I, J) = Evaluate("SumProduct(( Name = B" & I & ")*(Month =" & Cells(1, J) & ")* Daine)")

	  End If

    Next I

    Next J

  Application.ScreenUpdating = True

End Sub

وأسألك أخي خبور عن أمر فكرت فيه مليا (لمعرفتك أكثر بالأكواد) : هل يمكن إنشاء جدول (مصفوفة) عن طريق VBA نخزن فيها نتائج المعادلات ثم بعد الانتهاء منها نقوم بلصقها في النطاق المطلوب من الورقة؟؟؟

أخوكم بن علية

[Eid Mostafa]

^{السلام عليكم}

^{الأخ الكريم / خبور خير}

^{الأخ الكريم / بن علية}

^{كل الأخوة الذين شاركوا فى مساعدتى فى حل هذة المشكلة}

^{أتوجة إليكم جميعاً بخالص الشكر والتقدير على محاولاتكم القيمة والتى أضافت إلى الكثير}

^{وأتوجة بجزيل الشكر إلى الأخ / خبور خير}

^{فالحل الذى توصل إلية هو بالفعل ما أقصدة تماماً ، وإن كنت سأقوم بتقليل حجم أو مدى النطاقات ( الإسم ، الشهر ، المدين ، الدائن) وآمل أن يقل الوقت المستغرق فى الترحيل.}

^{مرة أخرى خالص شكرى وتقديرى لكل من ساهم فى حل هذة المشكلة.}

^{أفادكم الله جميعاً ، وزادكم علماً.}

^{خالص تحياتى وتقديرى}

^أخوكم

^{عيد مصطفى}

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

السلام عليكم

الاخ الفاضل بن عليه-----حفظه الله

وأسألك أخي خبور عن أمر فكرت فيه مليا (لمعرفتك أكثر بالأكواد) : هل يمكن إنشاء جدول (مصفوفة) عن طريق VBA نخزن فيها نتائج المعادلات ثم بعد الانتهاء منها نقوم بلصقها في النطاق المطلوب من الورقة؟؟؟

أخوكم بن علية

هل هذا ما تقصده ؟؟

Option Explicit

Const RR As Integer = 157

Const CC As Integer = 26

Sub kh_SumProduct()

Dim nAry() As Variant, mAry() As Variant, M_D() As Variant

Dim MyCalc As XlCalculation

Dim Last As Long, C As Integer, R As Integer, cN As Byte

Dim Na As Range, Mo As Range, M As Range, D As Range

On Error GoTo 1

'------------------------------------------

With Range("Name")

    Last = .Cells(.Rows.Count).End(xlUp).Row

End With

'------------------------------------------

Set Na = Range("Name").Resize(Last, 1)

Set Mo = Range("Month").Resize(Last, 1)

Set M = Range("Madine").Resize(Last, 1)

Set D = Range("Daine").Resize(Last, 1)

'------------------------------------------

ReDim nAry(1 To RR): ReDim mAry(1 To CC): ReDim M_D(1 To 2)

'------------------------------------------

MyCalc = Application.Calculation

Application.Calculation = xlCalculationManual

Application.ScreenUpdating = False

'------------------------------------------

M_D(1) = Kh_RgToAry(M): M_D(2) = Kh_RgToAry(D)

'------------------------------------------

With Sheet4

    For C = 1 To CC

	    If C Mod 2 = 1 Then cN = 1 Else cN = 2

	    For R = 1 To RR

		    If R = 1 Then mAry(C) = Kh_RgToAry(Mo, 1, .Cells(1, C + 2))

		    If C = 1 Then nAry(R) = Kh_RgToAry(Na, 1, .Cells(R + 3, 2))

		    .Cells(R + 3, C + 2) = WorksheetFunction.SumProduct(nAry(R), mAry(C), M_D(cN))

	    Next

    Next

End With

1:

Application.Calculation = MyCalc

Application.ScreenUpdating = True

'------------------------------------------

Erase nAry: Erase mAry

Set Na = Nothing: Set Mo = Nothing: Set M = Nothing: Set D = Nothing

End Sub

Function Kh_RgToAry(MyRng As Range, Optional T As Variant, Optional Test As Variant)

Dim co As Range, i As Long, Tb As Boolean

ReDim MyAr(1 To MyRng.Cells.Count)

For Each co In MyRng.Cells

    i = i + 1

    If IsMissing(T) Or IsMissing(Test) Then

		 MyAr(i) = CDbl(co)

    Else

	    Select Case Val(T)

		    Case 1: Tb = co = Test

		    Case 2: Tb = co <> Test

		    Case 3: Tb = co > Test

		    Case 4: Tb = co < Test

	    End Select

	    MyAr(i) = Abs(CInt(Tb))

    End If

Next

Kh_RgToAry = MyAr

Erase MyAr

End Function

شاهد المرفق

kh_SumProduct.rar

ودمتم في حفظ الله

[Eid Mostafa]

^{_{السلام عليكم}}

^{_{الأخ الكريم / خبور خير}}

^{_{أشكرك مرة أخرى على إهتمامك وإحيائك للموضوع مرة أخرى.}}

^{_{مرة أخرى خالص شكرى وتقديرى لكل من ساهم فى حل هذة المشكلة.}}

^{_{أفادكم الله جميعاً ، وزادكم علماً.}}

^{_{خالص تحياتى وتقديرى}}

^_أخوك

^{_{عيد مصطفى}}

[الـعيدروس]

السلام عليكم

كذا يااستاذ خبور خير

صارت مصنع تحف وليست تحفه فقط

زادك الله من علمه وفضله

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

تقبل مروري

تم تعديل ديسمبر 31, 2011 بواسطه alidroos

[saad abed]

السلام عليكم

كذا يااستاذ خبور خير

صارت مصنع تحف وليست تحفه فقط

زادك الله من علمه وفضله

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

تقبل مروري

اخى ابوعلى

صدق ابونصار

اعمالك تثبت لنا ان الاكواد تطيعك فى كل ما تريد

زادك الله من العلم ونفع بك

سعد عابد