محمد زيدان2024 قام بنشر يونيو 11, 2024 قام بنشر يونيو 11, 2024 (معدل) كيفية اضافة كود الى كود واجعلهم في كود واحد 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 بواسطه محمد زيدان2024
تمت الإجابة abouelhassan قام بنشر يونيو 11, 2024 تمت الإجابة قام بنشر يونيو 11, 2024 جرب لعله يفيدك 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
محمد زيدان2024 قام بنشر يونيو 11, 2024 الكاتب قام بنشر يونيو 11, 2024 لو حبيت اضعهم في Private Sub Worksheet_Change(ByVal Target As Range) يكون ازاي
abouelhassan قام بنشر يونيو 11, 2024 قام بنشر يونيو 11, 2024 جرب لعله يكون مفيدا 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
abouelhassan قام بنشر يونيو 11, 2024 قام بنشر يونيو 11, 2024 جرب لعله يكون مفيدا 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
الردود الموصى بها
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.