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

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

قام بنشر

السلام عليكم

ضع هذا الكود في حدث ورقة العمل


Private Sub Worksheet_Change(ByVal Target As Range)

Range("B4:E20").NumberFormat = "@"

If Not Intersect(Target, [B4:E20]) Is Nothing Then

    Select Case Target.Column

	    Case 2:

	    If Len(Target) < 2 Then Target = "0" & Target

	    Case 3:

	    If Len(Target) < 3 Then w = 3 - Len(Target)

	    Do Until Len(Target) = 3

			   Target = "0" & Target

		  Loop

	    Case 4:

	    If Len(Target) < 4 Then w = 4 - Len(Target)

	    Do Until Len(Target) = 4

			   Target = "0" & Target

		  Loop

	    Case 5:

	    If Len(Target) < 5 Then w = 5 - Len(Target)

	    Do Until Len(Target) = 5

			   Target = "0" & Target

		  Loop

    End Select

End If

End Sub

  • Like 1
قام بنشر (معدل)

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

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

أخوك بن علية

صفر على الشمال.rar

تم تعديل بواسطه hben
  • Like 1
قام بنشر (معدل)

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

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

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Application.ScreenUpdating = False

If Not Intersect(Target, [B4:E100]) Is Nothing Then

Target.NumberFormat = Application.WorksheetFunction.Rept(0, Target.Column)

End If

Application.ScreenUpdating = True

End Sub

أخوك بن علية

تم تعديل بواسطه hben
قام بنشر

السلام عليكم

هذا اختصار لكود الاستاذ بن عليه


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Not Intersect(Target, [B4:E20]) Is Nothing Then

Target.NumberFormat = Application.Rept(0, Target.Column)

End If

End Sub

قام بنشر (معدل)

السلام عليكم،

جرب الملف المرفق.

تحرير :

عذرا للاخ عبد الله والاخ بن علية لاني لم ار اجابتهما قبل وضع ردي.

صفر على الشمال (1).rar

تم تعديل بواسطه apt
قام بنشر

جميع الردود من الأخوة والأساتذة الكرام ممتازة وتؤدى الغرض .. خالص شكرى وامتنانى ..

قام بنشر (معدل)

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

ولكم جزيل الشكر ووافر الأحترام

تم تعديل بواسطه abassreda

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

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

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

Important Information