( تمت الاجابه ) كود محاذاة بالمنتصف (Align Center)

[Eid Mostafa]

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

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

هل بالإمكان عمل كود يقوم بعمل محاذاة بالمنتصف (Align Center) وذلك للقيم الصفرية فقط وفى كافة نطاق الملف

وسواء كانت ناتجة عن عملية إدخال يدوى أو ناتجة عن معادلة ؟

فى إنتظار إفاداتكم القيمة

أخوكم

عيد مصطفى

Breakdown - 2011.rar

[Eid Mostafa]

للرفع

[طارق محمود]

السلام عليكم

أخي الحبيب / عيد

جرب الكود التالي في حدث الورقة

Private Sub Worksheet_Activate()

For Each ce In UsedRange

    If ce.Value = 0 Then

	    With ce

		    .NumberFormat = "_(### ### ###_);[Red]_((###### ###);_(--_);_(@_)"

		    .HorizontalAlignment = xlCenter

		    .VerticalAlignment = xlCenter

	    End With

    End If

Next ce

End Sub


Private Sub Worksheet_Change(ByVal Target As Range)

For Each ce In UsedRange

    If ce.Value = 0 Then

	    With ce

		    .NumberFormat = "_(### ### ###_);[Red]_((###### ###);_(--_);_(@_)"

		    .HorizontalAlignment = xlCenter

		    .VerticalAlignment = xlCenter

	    End With

    End If

Next ce

End Sub

[Eid Mostafa]

أخى العزيز / طارق

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

أشكرك قبل أى شيء على إهتمامك

والآن إليك ما حدث

بالفعل قام الكود بعمل محاذاة بالمنتصف للقيمة بعدما أصبحت صفراً

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

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

فى إنتظار إفاداتك القيمة

أخوك

عيد مصطفى

[طارق محمود]

السلام عليكم

علي عجالة جرب أخي هذا التغيير

Private Sub Worksheet_Activate()

  For Each ce In UsedRange

    If IsNumeric(ce) = False Then GoTo 1

    If ce.Value = 0 Then

		    With ce

				    .NumberFormat = "_(### ### ###_);[Red]_((###### ###);_(--_);_(@_)"

				    .HorizontalAlignment = xlCenter

				    .VerticalAlignment = xlCenter

		    End With

    Else

		    With ce

				    .HorizontalAlignment = xlRight

				    .VerticalAlignment = xlBottom

		    End With


    End If

1 Next ce

End Sub


Private Sub Worksheet_Change(ByVal Target As Range)

  For Each ce In UsedRange

    If IsNumeric(ce) = False Then GoTo 1

    If ce.Value = 0 Then

		    With ce

				    .NumberFormat = "_(### ### ###_);[Red]_((###### ###);_(--_);_(@_)"

				    .HorizontalAlignment = xlCenter

				    .VerticalAlignment = xlCenter

		    End With

    Else

		    With ce

				    .HorizontalAlignment = xlRight

				    .VerticalAlignment = xlBottom

		    End With


    End If

1 Next ce

لم أجد وقتا لتجريبه

أخبرني النتيجة

[Eid Mostafa]

أخى العزيز / طارق

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

الله ينور عليك طبعاً

ولتسمح لى فقد قمت بعمل التعديل التالى على الكود :-

Private Sub Worksheet_Activate()

For Each ce In UsedRange

If IsNumeric(ce) = False Then GoTo 1

If ce.Value = 0 Then

With ce

.NumberFormat = "_(### ### ###_);[Red]_((### ### ###);_(--_);_(@_)"

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

Else

With ce

.HorizontalAlignment = xlRight

.VerticalAlignment = xlCenter

End With

End If

1 Next ce

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)

For Each ce In UsedRange

If IsNumeric(ce) = False Then GoTo 1

If ce.Value = 0 Then

With ce

.NumberFormat = "_(### ### ###_);[Red]_((### ### ###);_(--_);_(@_)"

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

End With

Else

With ce

.HorizontalAlignment = xlRight

.VerticalAlignment = xlCenter

End With

End If

1 Next ce

End Sub

حيث أن الكود وفقاً لما أرسلته إلى قد قام بعمل محاذاه رأسيه (أسفل) وليس بالمنتصف وذلك لأرقام سطر 14 ولا أعلم لماذا

ولكن بعد تعديل الكود إلى ما هو بأعلاه تم حل تلك المشكله (منكم نستفيد طبعاً)

والآن وإن كان لديك ما يسمح من الوقت فقد بقيت مشكله شكليه بسيطه ولم أستطع حلها ألا وهى

إن دققت النظر فى G10 ، G11 ستجد أن هنالك عدم تماثل فى المحاذاه وقد حاولت أن أحلها ولكن لم أفلح فى ذلك

وأنا أريد إتباع نمط محاذاة ماهو فى G11

مرة أخرى ما وصلنا إليه هو أمر فوق الرائع

ولكن إن أمكننا حل تلك النقطه الأخيره سيكون الأمر أروع و أروع

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

أخوك

عيد مصطفى

Breakdown - 2011.rar

[طارق محمود]

السلام عليكم

أضفت لك سطر ترحيل هامش الخلية بمقدار 1 كما في G11

وهو هذا السطر لكلا الكودين

.IndentLevel = 1

وكذلك اضفت سطرين في أول الكود لإيقاف عمليات الحساب وتغير الشاشة مع استرجاعهما في آخر الكود بغرض تسريع النتائج (حيث كانت بطيئة نسبيا وهما هذان في أول الكود

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

وهذان في آخره

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic

جرب الكود الآن كاملا كالتالي

Private Sub Worksheet_Activate()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

  For Each ce In UsedRange

    If IsNumeric(ce) = False Then GoTo 1

    If ce.Value = 0 Then

				    With ce

								    .NumberFormat = "_(### ### ###_);[Red]_((### ### ###);_(--_);_(@_)"

								    .HorizontalAlignment = xlCenter

								    .IndentLevel = 1

								    .VerticalAlignment = xlCenter

				    End With

    Else

				    With ce

								    .HorizontalAlignment = xlRight

								    .IndentLevel = 1

								    .VerticalAlignment = xlCenter

				    End With


    End If

1 Next ce

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic


End Sub


Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual


  For Each ce In UsedRange

    If IsNumeric(ce) = False Then GoTo 1

    If ce.Value = 0 Then

				    With ce

								    .NumberFormat = "_(### ### ###_);[Red]_((### ### ###);_(--_);_(@_)"

								    .HorizontalAlignment = xlCenter

								    .IndentLevel = 1

								    .VerticalAlignment = xlCenter

				    End With

    Else

				    With ce

								    .HorizontalAlignment = xlRight

								    .IndentLevel = 1

								    .VerticalAlignment = xlCenter

				    End With


    End If

1 Next ce

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic


End Sub

[Eid Mostafa]

أخى العزيز / طارق

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

الله ينور عليك طبعاً بالفعل الملف أصبح أسرع

وبالفعل أتى هامش الخلية بمقدار 1 أو (IndentLevel = 1) بثماره

ولكن الصفر أو القيم الصفريه أصبحت محاذيه لليسار ، وليست بالوسط

فهل لك التكرم بإرجاعها إلى الوسط مع الإبقاء على ما توصلنا إليه من سرعه وأداء أسرع ؟؟؟؟

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

أخوك

عيد مصطفى

Breakdown - 2011.rar

[طارق محمود]

السلام عليكم

أخي عيد

إحذف سطر

.IndentLevel = 1

من جزئية الصفر ليصبح الكود كالتالي

Private Sub Worksheet_Activate()

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual

  For Each ce In UsedRange

    If IsNumeric(ce) = False Then GoTo 1

    ce.NumberFormat = "_(### ### ###_);[Red]_((### ### ###);_(--_);_(@_)"

    If ce.Value = 0 Then

	    With ce

		    .HorizontalAlignment = xlCenter

		    .VerticalAlignment = xlCenter

	    End With

    Else

	    With ce

		    .HorizontalAlignment = xlRight

		    .IndentLevel = 1

		    .VerticalAlignment = xlCenter

	    End With


    End If

1 Next ce

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic


End Sub


Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False

Application.Calculation = xlCalculationManual


  For Each ce In UsedRange

    If IsNumeric(ce) = False Then GoTo 1

    ce.NumberFormat = "_(### ### ###_);[Red]_((### ### ###);_(--_);_(@_)"

    If ce.Value = 0 Then

	    With ce

		    .HorizontalAlignment = xlCenter

		    .VerticalAlignment = xlCenter

	    End With

    Else

	    With ce

		    .HorizontalAlignment = xlRight

		    .IndentLevel = 1

		    .VerticalAlignment = xlCenter

	    End With


    End If

1 Next ce

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic


End Sub

[Eid Mostafa]

_{أخى العزيز / طارق}

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

_{أحسنت والله ينور عليك طبعاً كده كله تمام التمام ، لا أملك إلا أن أقول بالفعل أنت عبقرى}

_{أنت وصلت للمطلوب ولكن أكيد تعبتك معايا كتير}

_{أنا متعب دائماً فى طلباتى}

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

_أخوك

_{عيد مصطفى}

[Eid Mostafa]

أخى العزيز / طارق

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

العذر كل العذر مرة أخرى

هل يمكن تطبيق الكود على نطاق محدد ؟؟؟ وذلك لتفادى أمر ما لا زلت أفكر به

بمعنى أنى أريد تطبيقه فقط على النطاق (المدى) التالى C7 إلى I14 ، فكيف أعدل بالكود ؟

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

أخوك

عيد مصطفى

[طارق محمود]

السلام عليكم

أخي الحبيب

لاتنزعج أبدا من الأسئلة

فهذه أسلم الطرق لحفر المعلومة في الرأس

ردا علي سؤالك

في الحقيقة الكود الأول ليس له داعي

يلزمك إضافة السطورالتالية في أول الكود

Dim myRange As Range

Set myRange = [C7:I14]

If Intersect(Target, myRange) Is Nothing Then Exit Sub

وكذلك تغيير السطر For Each ce In UsedRange إلي For Each ce In myRange يعني سيكون الكود كالتالي

Private Sub Worksheet_Change(ByVal Target As Range)

Dim myRange As Range

Set myRange = [C7:I14]

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 = "_(### ### ###_);[Red]_((### ### ###);_(--_);_(@_)"

    If ce.Value = 0 Then

		    With ce

				    .HorizontalAlignment = xlCenter

				    .VerticalAlignment = xlCenter

		    End With

    Else

		    With ce

				    .HorizontalAlignment = xlRight

				    .IndentLevel = 1

				    .VerticalAlignment = xlCenter

		    End With


    End If

1 Next ce

Application.ScreenUpdating = True

Application.Calculation = xlCalculationAutomatic


End Sub

[Eid Mostafa]

أخى العزيز / طارق

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

لقد جربت الكود بعد التعديل وأتى بثماره تماماً

بالفعل لك كل التقدير والإحترام

أنا فقط أخشى أن أثقل عليك بطلباتى من ناحية

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

ما يستدعى السؤال ثم السؤال مرات ومرات

وهذا ما يشعرنى بالإحراج أحياناً كثيره

ولكنك دائماً تبدد لى هذا الإحراج

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

أخوك

عيد مصطفى

[Eid Mostafa]

أخى العزيز / طارق

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

ممكن معلش تكمل جميلك وتفيدنى عن ما إذا بالإمكان عمل نطاقان مختلفان للتطبيق

بمعنى نحن الآن وصلنا إلى Set myRange = [C7:I14]

فهل يمكن على سبيل المثال إضافة نطاق آخر إلى الكود وليكن Set myRange = [Q9:V20] على سبيل المثال

فهل هذا جائز ؟؟؟؟؟

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

أخوك

عيد مصطفى

[طارق محمود]

السلام عليكم

نعم أخي

يوجد دالة جميلة إسمها Union

تستطيع عمل مثلا

Set myRange = Union([C7:I14], [Q9:V20])

[Eid Mostafa]

أخى العزيز / طارق

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

أشكرك مقدماً قبل تجربة الكود

علماً بأنى كلى ثقه فى كل ما يأتينى منك

وإعذرنى فلى طلب أخر منك

أرجو منك الإطلاع على تلك المشاركه

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

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

أخوك

عيد مصطفى

[Eid Mostafa]

أخى العزيز / طارق

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

بعد التجربه تمام التمام الله ينور

بارك الله فيك

وطبعاً زى مانت عارف مش هعدى الموضوع بالساهل كده ولازم أسأل أكتر

هل هذة الداله لها حد أقصى ؟؟؟؟؟ وكم هو ذلك الحد ؟؟؟؟؟؟

بمعنى هل يمكننى عمل ما يلى على سبيل المثال :-

Set myRange = Union([C7:I14], [Q9:V20], [X90:Y120], [AB15:BC18])

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

أخوك

عيد مصطفى

[طارق محمود]

السلام عليكم

لاأعتقد أن لها حد أقصي

ولو أني لاأفضل ان يزيد عدد حروف المعادلة (بما فيها من دوال) عن 255 حرف

(كنت قد قرات مرة أن هذا يؤدي لمشاكل)

إن شرحت لي ماتريد بالضبط ، فقد يكون هناك حلول أفضل

مثلا أنظر الفيديو المرفق

إخترت أماكن ليس لها علاقة ببعض وليست بنفس النسق

المهم تكون مستمر بالضغط علي زر الـ Ctrl

ثم تسمي هذا الخليط من النطاقات ماشئت

وتطلب من الكود ان يتعامل مع هذا المسمي

في الفيديو ، سميت النطاقات المختلفة (مجتمعة) EID

Rang_Name.rar

[طارق محمود]

بالنسبة لمشاركتك #16 ذهبت للموضوع فرأيت اخونا بن عليه قد أفادك فيه

[Eid Mostafa]

أخى العزيز / طارق

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

والله يا سيدى القلوب عند بعضها

طبعاً وقبل أى شئ أشكرك على إهتمامك الدائم

وبالتجربه أضفت نطاقات ليست لها علاقه ببعضها إطلاقاً ونجحت التجربه

فإنظر إلى ذلك السطر :-

Set myRange = Union([b4:C120], [F4:P120], [R4:S120], [b128:C146], [F128:P146], [R128:S146])

أضفته إلى أحد الشيتات ونجح

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

أخوك

عيد مصطفى