دمج كودين

[Eid Mostafa]

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

 

الأخوه الأعزاء

 

 

الكودان التاليان يعملان على نفس الملف ونفس الشيت أيضاً (مرفق ملف)

لذا أرجو التكرم بدمجهما معاً فى ليصبحا كود واحد بدلاً من إثنان

 

 

الكود الأول :

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C2,E6,C6,C7")) Is Nothing Then
Application.ScreenUpdating = False
On Error Resume Next
If Target Is emptey Then
Sheet2.Range("B12:C403,E12:N400").ClearContents
R = 12: sum1 = 0: sum2 = 0: sum3 = 0: sum4 = 0
For I = 2 To Sheet1.Range("C2000").End(xlUp).Row + 1
Application.ScreenUpdating = False
If Sheet2.Range("E6").Value = Sheet1.Cells(I, "C") Then
If Sheet2.Range("C6").Value > Sheet1.Cells(I, "H") Then
sum3 = sum3 + Sheet1.Cells(I, 1): sum4 = sum4 + Sheet1.Cells(I, 2)
End If
If Sheet2.Range("C7").Value = "" Then GoTo a2
If Sheet2.Range("C7").Value >= Sheet1.Cells(I, "H") Then
a2:
If Sheet2.Range("C6").Value = "" Then GoTo a3
If Sheet2.Range("C6").Value <= Sheet1.Cells(I, "H") Then
a3:
Sheet2.Cells(R, 2) = Sheet1.Cells(I, 1)
Sheet2.Cells(R, 3) = Sheet1.Cells(I, 2)
Sheet2.Cells(R, 5) = Sheet1.Cells(I, 5)
Sheet2.Cells(R, 10) = Sheet1.Cells(I, 9)
Sheet2.Cells(R, 11) = Sheet1.Cells(I, 7)
Sheet2.Cells(R, 12) = Sheet1.Cells(I, 6)
Sheet2.Cells(R, 13) = Sheet1.Cells(I, 8)
Sheet2.Cells(R, 14) = R - 11
sum1 = sum1 + Sheet1.Cells(I, 1)
sum2 = sum2 + Sheet1.Cells(I, 2)
R = R + 1
End If
End If
End If
Next I
[L5] = sum1: [M5] = sum2: [N5] = sum1 - sum2
[L4] = sum3: [M4] = sum4: [N4] = sum3 - sum4
[L7] = [N5] + [N4]
If [L7] < 0 Then
[N7] = "دائن"
ElseIf [L7] > 0 Then
[N7] = "مدين"
Else
[N7] = "--"
End If
End If
End If
If Not Intersect(Target, Range("C2")) Is Nothing Then
Application.ScreenUpdating = False
On Error Resume Next
Application.ScreenUpdating = False
[E6] = Application.WorksheetFunction.VLookup(Target, Sheet3.Range("data"), 2, False)
End If
If Not Intersect(Target, Range("E6")) Is Nothing Then
Application.ScreenUpdating = False
On Error Resume Next
Application.EnableEvents = False
Target.Offset(-4, -2).Value = Application.WorksheetFunction.VLookup(Target, Sheet3.Range("G1:H200"), 2, False)
Application.EnableEvents = True
End If

الكود الثانى :

Dim MyRange As Range
Set MyRange = Union([B12:C12], [D12:D400], [B404:D404], [C409:N410])
If Intersect(Target, MyRange) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
  For Each ce In MyRange
     If IsNumeric(ce) = False Then GoTo 1
          ce.NumberFormat = "_(#,##0.00_);[Red]_((#,##0.00);_(--_);_(@_)"
     If ce.Value = 0 Then
        With ce
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
    Else
        With ce
            .HorizontalAlignment = xlRight
            .VerticalAlignment = xlCenter
        End With
    End If
1 Next ce
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

أرجو أن أكون قد وفقت فى شرح ما أقصده.

 

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

 

أخوكم

عيد مصطفى

Code Merge.rar

[Eid Mostafa]

للرفــــــــــــــــــــــــــــــــــــــــــــــع

 

رفع الله قدركم

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

اخي الكودين في كود واحد في الملف المرفق (في حدث التغيير في ورقة العمل)

[Eid Mostafa]

]

اخي الكودين في كود واحد في الملف المرفق (في حدث التغيير في ورقة العمل)

 

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

 

أخى العزيز / عبد الله

 

 

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

 

ولكن أخى العزيز لا أعتقد كما ذكرت فى ردك بأن الكودان فى كود واحد (وفقاً لمعلوماتى المتواضعه)

 

فالكود الأول هو كود ترحيل ، والكود الثانى هو كود لمحاذاة الأرقام

 

وستجد أخى العزيز أن آلية عمل كل كود تختلف عن الآخر

 

فالكود الأول (كود الترحيل) يعمل من خلال تغيير خلية التاريخ (خليه C6)

بينما الكود الثانى (كود محاذاة الأرقام) يعمل من خلال الضغط على أى خليه بالنطاقات المحدده له (خليه D12) على سبيل المثال.

 

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

كما هو موضح بالخلايا من (D13 : D20) (وهذا ينفى فكرة أنهما كود واحد)

 

فى حين أنك إن ذهبت إلى خليه D12 على سبيل المثال وضغطت على F2 ثم Enter فستجد أن الأرقام قد أخذت وضع المحاذاه على اليمين

 

أرجو أن أكون قد وفقت فى شرح ما أقصده.

 

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

 

أخوك

عيد مصطفى

Code Merge (2).rar

المحاذاه الخاطئه.rar

طريقة تعديل المحاذاه.rar

المحاذاه الصحيحه.rar

تم تعديل يوليو 26, 2013 بواسطه Eid Mostafa

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

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

 

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

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

من المفروض أن الكود بجزئيه يشتغل تلقائيا بمجرد أي تغيير يحدث في الورقة...

 

الملف المرفق : Code Merge.rar

 

أخوك بن علية

تم تعديل يوليو 26, 2013 بواسطه بن علية حاجي

[Eid Mostafa]

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

 

أخى الحبيب والكريم / بن علية

 

 

أشكرك جزيل الشكر على مشاركتك هذه وإهتمامك بالرد

 

ولكن أخى العزيز الكود أصبح يحذف قيم عمود الرصيد (عمود D) ويظهر خالى تماماً من أى قيم

 

كذلك أصبحت البيانات تظهر فى أعمده أخرى مختلفه تماماً (مرفق صوره)

 

فقط جرب أن تقوم بتغيير التاريخ (بخليه C6) على سبيل المثال وراقب مايحدث

 

فهل بإمكانك التكرم بمراجعة الكود مرة أخرى

 

 

أرجو أن أكون قد وفقت فى شرح ما أقصده.

 

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

 

أخوك

عيد مصطفى

Code Merge (3).rar

تأثير الكود بعد التعديل.rar

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

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

 

أخي الكريم عيد مصطفى، حاولت أن أفهم مبدأ الكود في بدايته (الشروط) لكن دون جدوى...  تمت تعديلات على الكود حسب المطلوب (أرجو ذلك)... بالنسبة للبيانات التي كُتبت في اليسار (خارج الجدول في الصورة عند تنفيذ الكود) كان بسبب أن تنسيق الملف في الرد الأول يختلف عن تنسيق الملف في ردك الأخير، فقد جعلت في جدول الملف عمود "بيان" من خمسة أعمدة (من E إلى I) بينما في الثاني جعلت له عمودا واحدا (العمود E) وتركت معادلات الترحيل في الكود كما هي... 

 

أرجو أني فهمت واستوفيت المطلوب...

 

أخوك بن علية

 

الملف المرفق : Code Merge (4).rar

[Eid Mostafa]

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

 

أخى الكريم والحبيب / بن علية

 

 

أشكرك جزيل الشكر على متابعتك ومشاركتك القيمه هذه

 

وأعتذر لك عن الخطأ غير المقصود إطلاقاً فى الإختلاف بين تنسيقات الملفات (رمضان كريم  ) .

 

كما أشكرك أيضاً على حلولك الأكثر من رائعه دائماً

وسأحاول أن أصل إلى مبدأ (شروط) الكود ، وأرجو ألا أكون قد أثقلت عليك بطلباتى الكثيره

 

     

 

أعانك الله على أمور حياتك ، وبارك لك فى وقتك وفى عملك وفى أولادك

 

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

 

أخوك

عيد مصطفى

تم تعديل يوليو 27, 2013 بواسطه Eid Mostafa