كيفية اضافة كود الى كود

[محمد زيدان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

[abouelhassan]

جرب لعله يفيدك

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

 

[محمد زيدان2024]

لو حبيت اضعهم في Private Sub Worksheet_Change(ByVal Target As Range)

يكون ازاي

[abouelhassan]

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

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

 

[محمد زيدان2024]

خطأ في الكود

 

[abouelhassan]

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

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