محمد زيدان2024 قام بنشر يونيو 11 مشاركة قام بنشر يونيو 11 (معدل) كيفية اضافة كود الى كود واجعلهم في كود واحد Sub Names_Adjust() 'ضبط الأسماء قبل عملية الأبجدة '-------------------------- Dim ch Application.ScreenUpdating = False With Range("E10:E1009") For Each ch In Array("إ", "أ", "آ") .Replace CStr(ch), "ا", , , True Next .Replace "ة", "ه", , , True .Replace "ي ", "ى ", , , True End With Kill_Spaces Application.ScreenUpdating = True End Sub مع الكود ده Sub Kill_Spaces() Dim sh As Worksheet, lr As Long, i As Long Set sh = ThisWorkbook.ActiveSheet lr = sh.Cells(Rows.Count, 5).End(xlUp).Row 'Application.ScreenUpdating = False For i = 10 To lr Do While InStr(sh.Cells(i, 5), " ") > 0 sh.Cells(i, 5).Value = Replace(sh.Cells(i, 5), " ", " ") Loop sh.Cells(i, 5).Value = Trim(sh.Cells(i, 5).Value) Next i 'Application.ScreenUpdating = True End Sub تم تعديل يونيو 11 بواسطه محمد زيدان2024 رابط هذا التعليق شارك More sharing options...
أفضل إجابة abouelhassan قام بنشر يونيو 11 أفضل إجابة مشاركة قام بنشر يونيو 11 جرب لعله يفيدك Sub Names_Adjust() ' ضبط الأسماء قبل عملية الأبجدة ' -------------------------- Dim ch Application.ScreenUpdating = False With Range("E10:E1009") For Each ch In Array("إ", "أ", "آ") .Replace CStr(ch), "ا", , , True Next .Replace "ة", "ه", , , True .Replace "ي ", "ى ", , , True End With ' إزالة المسافات الزائدة Dim sh As Worksheet, lr As Long, i As Long Set sh = ThisWorkbook.ActiveSheet lr = sh.Cells(Rows.Count, 5).End(xlUp).Row For i = 10 To lr Do While InStr(sh.Cells(i, 5), " ") > 0 sh.Cells(i, 5).Value = Replace(sh.Cells(i, 5), " ", " ") Loop sh.Cells(i, 5).Value = Trim(sh.Cells(i, 5).Value) Next i Application.ScreenUpdating = True End Sub 1 رابط هذا التعليق شارك More sharing options...
محمد زيدان2024 قام بنشر يونيو 11 الكاتب مشاركة قام بنشر يونيو 11 لو حبيت اضعهم في Private Sub Worksheet_Change(ByVal Target As Range) يكون ازاي رابط هذا التعليق شارك More sharing options...
abouelhassan قام بنشر يونيو 11 مشاركة قام بنشر يونيو 11 جرب لعله يكون مفيدا Private Sub Worksheet_Change(ByVal Target As Range) ' تحقق إذا كانت التغييرات داخل النطاق المطلوب If Not Intersect(Target, Me.Range("E10:E1009")) Is Nothing Then ' ضبط الأسماء قبل عملية الأبجدة Dim ch As Variant Application.ScreenUpdating = False With Me.Range("E10:E1009") For Each ch In Array("إ", "أ", "آ") .Replace CStr(ch), "ا", , , True Next .Replace "ة", "ه", , , True .Replace "ي ", "ى ", , , True End With ' إزالة المسافات الزائدة Dim lr As Long, i As Long lr = Me.Cells(Me.Rows.Count, 5).End(xlUp).Row For i = 10 To lr Do While InStr(Me.Cells(i, 5), " ") > 0 Me.Cells(i, 5).Value = Replace(Me.Cells(i, 5), " ", " ") Loop Me.Cells(i, 5).Value = Trim(Me.Cells(i, 5).Value) Next i Application.ScreenUpdating = True End If End Sub رابط هذا التعليق شارك More sharing options...
محمد زيدان2024 قام بنشر يونيو 11 الكاتب مشاركة قام بنشر يونيو 11 خطأ في الكود رابط هذا التعليق شارك More sharing options...
abouelhassan قام بنشر يونيو 11 مشاركة قام بنشر يونيو 11 جرب لعله يكون مفيدا Private Sub Worksheet_Change(ByVal Target As Range) Dim ch As Variant Dim cell As Range ' تحقق إذا كانت التغييرات داخل النطاق المطلوب If Not Intersect(Target, Me.Range("E10:E1009")) Is Nothing Then Application.EnableEvents = False Application.ScreenUpdating = False ' ضبط الأسماء وإزالة المسافات الزائدة لكل خلية تم تغييرها For Each cell In Intersect(Target, Me.Range("E10:E1009")) ' ضبط الأسماء قبل عملية الأبجدة For Each ch In Array("إ", "أ", "آ") cell.Value = Replace(cell.Value, CStr(ch), "ا", 1, -1, vbTextCompare) Next cell.Value = Replace(cell.Value, "ة", "ه", 1, -1, vbTextCompare) cell.Value = Replace(cell.Value, "ي ", "ى ", 1, -1, vbTextCompare) ' إزالة المسافات الزائدة Do While InStr(cell.Value, " ") > 0 cell.Value = Replace(cell.Value, " ", " ") Loop cell.Value = Trim(cell.Value) Next cell Application.EnableEvents = True Application.ScreenUpdating = True End If End Sub 1 رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان