تنسيق الخليه بشرط

[محمد مصطفى درويش]

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

اخواني هل تستطيعوا مساعدتي في كتابة كود برمجي  في العمود a وفي اي خلية في العمود اذا كان النص بالخلية بدون فراغ  فاريد تنسيق النص shring to fit ( احتواء مناسب) واذا كان النص بالخلية بفراغ بكون التنسيق wrap text (التفاف النص )  بمعنى اذا كان النص في اي خلية بالعمود a  يتكون من كلمة واحدة يكون التنسيق  shring to fit ( احتواء مناسب) واذا كان النص في اي خلية بالعمود a يتكون من كلمتين فأكثر   بكون التنسيق wrap text (التفاف النص )    شاكرا جهودكم مرفق ملف العمل الجديد لتوضيح الفكرة

ملف العمل.xlsx

[أبوأحـمـد]

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

تفضل

Sub test()
Dim x As Long
For x = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If InStr(2, Range("A" & x), " ") > 0 Then
Range("A" & x).WrapText = True
Else
Range("A" & x).WrapText = False
Range("A" & x).ShrinkToFit = True
End If
Range("A" & x).EntireRow.AutoFit
Next
End Sub

 

[محمد مصطفى درويش]

بارك الله فيك وفي مالك وعيالك،  اخي الكريم عند التجريب وجدت ان الكود يعمل عند ربطه بزر هل يمكن وضع الكود ليعمل تلقائيا دون ربطه بزر ويكون للشيت رقم 1 وهل يمكن التعديل عليه لينفذ الامر في الخلية bk23 فقط بدلا من اي خلية في العمود A شاكرا جهودك

تم تعديل أغسطس 6, 2023 بواسطه محمد مصطفى درويش

[أبوأحـمـد]

تفضل

Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
Dim x As Long
Set myRange = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row + 1)
If Target.CountLarge > 1 Then Exit Sub
If Intersect(Target, myRange) Is Nothing Then Exit Sub

If InStr(2, Target, " ") > 0 Then
Target.WrapText = True
Else
Target.WrapText = False
Target.ShrinkToFit = True
End If
Target.EntireRow.AutoFit

End Sub

 

[محمد مصطفى درويش]

بارك الله فيك استاذنا