إستخراج أرصدة الموردين إلى ملف جديد

[أبو أنس حاجب]

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

رمضان كريم

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

أبو أنس

Suppliers2012.rar

[أبو أنس حاجب]

للرفع

تقبل الله منا ومنكم الصيام والقيام وصالح الأعمال

[الخالدي]

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

رمضان كريم

تقبل الله منا ومنكم الصيام والقيام وصالح الأعمال

مرفق محاول للحل حسب فهمي للمطلوب

في حفظ الله

Suppliers2012_2.rar

[أبو أنس حاجب]

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

أستاذي وسيدي الفاضل الخالدي حفظك الله وأكرم منزلك في الفردوس الأعلى من الجنة.

وزادك الله علماً على علم وأنا فخورٌ بك جداً ,من خلال الكود فهو يحقق المطلوب بقوة وبدقة محترف لمست ذلك من خلال أنني لم أفهم من الكود أي شئ (وذلك لجهلي وأن شاء الله أذا كنا ممن أراد الله لنا اللقاء في اليمن سوف أترجاك أن تعلم أبني أنس هذا الأبداع الراقي).

لو لاحظت هنالك زر في المرفق يقوم بانشاء ملف جديد وهو المطلوب على أن يتم نقل الأرصدة اليه أن أمكن فملفي الأصلي يحتوي على عدة صفحات ومنها البعض مخفية وبه العديد من الأكواد أرجو تكرماً وتفضلاً أن تقوم بالتعديل على الكود حتى يقوم بالحفاظ على الملف الأصلي كاملًاً وليس ورقة واحدة فقط ولايهم أسم الملف المهم أن يتم أنشاء ملف طبق الأصل متكامل على أن لايؤثر على باقي الصفحات.

رضي الله عنك وأرضى الناس عليك وبارك بك وفيك وبذريتك من بعدك إلى يوم الدين.

أبو أنس ناصر حاجب

[الخالدي]

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

اخي الفاضل أبو أنس حاجب أكرم الله منزلك في الفردوس الأعلى من الجنة. حفظك الله وأقر عينك بأبنك أنس ورزقك بره ونسال الله لأنس ما عهدناه من أبيه طيب الكلام ودماثة الأخلاق.

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

وبالنسبة لحفظ الملف كاملا فالكود يحتاج الى تعديلات واضافات , فامهلني بعض الوقت خاصة مع استمرار انقطاع الكهرباء في اليمن.

في أمان الله

[الخالدي]

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

اخي الكريم

جرب الكود التالي والذي يقوم بحفظ الملف باسم جديد

Sub AL_KHALEDI()

'======حفظ الملف باسم جديد====

ActiveWorkbook.Save 'حفظ اي تغيرات في الملف الاصلي قبل حفظه باسم جديد (اختياري)

S = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name

Application.Dialogs(5).Show

If ActiveWorkbook.Path & "\" & ActiveWorkbook.Name = S Then Exit Sub 'التحقق من حفظ الملف باسم جديد

'=========تحديد وتكوين نطاقات البياتات====

LR = Sheets("DATA").Range("C65000").End(xlUp).Row

RW = LR - 6 + 1

If RW < 1 Then Exit Sub

Set Rn0 = Sheets("DATA").Range("A6:L" & LR)

Set Rn1 = Rn0.Columns(3)

Set Rn2 = Rn0.Columns(10)

Set Rn3 = Rn0.Columns(11)

'=========انشأ مصفوفات التخزين المؤقت في الذاكرة====

ReDim Arr1(1 To RW)

ReDim Arr2(1 To RW)

ReDim Arr3(1 To RW)

'=========استخراج ارصدة الموردين وحفظها في المصفوفات المؤقتة====

For i = 1 To RW

If Application.CountIf(Range(Rn1.Cells(1, 1), Rn1.Cells(i, 1)), Rn1.Cells(i, 1)) = 1 Then

	 x = Application.SumIf(Rn1, Rn1.Cells(i, 1), Rn2) - Application.SumIf(Rn1, Rn1.Cells(i, 1), Rn3)

	 If x <> 0 Then

		 r = r + 1

		 Arr1(r) = Rn1.Cells(i, 1)

		 If x > 0 Then

		 Arr2(r) = x

		 Else

		 Arr3(r) = Abs(x)

		 End If

	 End If

End If

Next i

'=========مسح جدول البيانات وتعبئة جدول البيانات بمحتويات المصفوفات====

If Sheets("DATA").Unprotect = True Then U = 1 'فك حماية الورقة اذا كانت محمية

Rn0.ClearContents

Rn1.Cells(1, 1).Resize(r).Value = WorksheetFunction.Transpose(Arr1)

Rn2.Cells(1, 1).Resize(r).Value = WorksheetFunction.Transpose(Arr2)

Rn3.Cells(1, 1).Resize(r).Value = WorksheetFunction.Transpose(Arr3)

If U = 1 Then

Sheets("DATA").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _

	 , AllowFormattingCells:=True, AllowSorting:=True, AllowFiltering:=True 'اعادة حماية الورقة اذا كانت محمية سابقا

End If

'=========مسح محتويات الذاكرة====

Set Rn0 = Nothing: Set Rn1 = Nothing: Set Rn2 = Nothing: Set Rn3 = Nothing

Erase Arr1: Erase Arr2: Erase Arr3

MsgBox ("تم بحمد الله")

End Sub

ارجوا ان يكون المطلوب

في أمان الله

Suppliers2012_3.rar

[أبو أنس حاجب]

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

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

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

وهو عندي على الأوفيس 2003 سريع جداً رغم حجم البيانات الكبير فلم يتجاوز العشرون ثانية في التنفيذ وحتى أن أخذ مني خمس دقائق فسوف أعتبره سريع لما يقوم به من مهمة غاية في الدقة.

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

لعلي أوفيتك حقك

أبو أنس ناصر حاجب

[الخالدي]

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

اخي الفاضل أبو أنس ناصر حاجب

ولك مثل دعائك لي و زيادة

لقد كفيت ووفيت

والحمدلله ان العمل حقق طلبك

في أمان الله