المطلوب كود لحذف المسافات فى بداية الخلية ونهايتها

[عادل ابوزيد]

السلام  عليكم اساتذتى الكرام

المطلوب كود لنفيذه على 46000 صف يقوم بحذف المسافات الموجوده فى بداية النص داخل الخلية وفى نهايته وكذلك ان وجد مسافات بين النصوص مع الحفاظ على المسافات الطبيعية بين الكلمات والاسماء التى تبدا بعبد مع اسماء الله الحسنى 

مع العلم انه بالبحث بالمنتدى وجدت كود للعلامه عبد الله باقشير إلا انه لم ينفذ على الملف 

تقبلوا تحياتى وتقديرى

حذف المسافات.xlsx

[حسونة حسين]

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

استخدم هذا المعادله واسحبها الي قدر ما تحتاج من الصفوف

=CLEAN(TRIM(C2))

 

[عادل ابوزيد]

اشكرك على الرد والاهتمام .. ممكن كود ان امكن

[حسونة حسين]

تفضل

Sub Clean_Trim()
    Dim rng As Range
    Set rng = sheet1.Range("C2:C46023")
    rng.Value = Evaluate("INDEX(CLEAN(TRIM(" & rng.Address & ")),)")
End Sub

 

[hegazee]

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

بعد إذن أستاذنا / حسونه   الكود التالي يقوم بعمل اللازم و ضع مسافة بين عبد و أسماء الله الحسنى مثل عبد الله كلمتان و سيكون بعده كود آخر بدون مسافة أي عبدالله مثلا ستكون كلمة واحدة

الكود الأول ( عبد الله)

Sub CleanSpaces()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim t As String
    Dim reAbd As Object
    Dim scr As Boolean, calc As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    scr = Application.ScreenUpdating
    calc = Application.Calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set reAbd = CreateObject("VBScript.RegExp")
    With reAbd
        .Global = True
        .IgnoreCase = False
        .Pattern = "عبد(?=[اأإآء-يؤئبةتى])"
    End With

    For Each cell In ws.Range("C1:C" & lastRow)
        If Not cell.HasFormula Then
            If VarType(cell.Value) = vbString Then
                t = CStr(cell.Value)

                 
                t = Replace(t, Chr(160), " ")
                t = Replace(t, vbTab, " ")
                t = Replace(t, ChrW(8206), "")
                t = Replace(t, ChrW(8207), "")
                t = Application.WorksheetFunction.Trim(t)

                t = reAbd.Replace(t, "عبد ")

                t = Application.WorksheetFunction.Trim(t)

                If cell.Value <> t Then cell.Value = t
            End If
        End If
    Next cell

    Application.ScreenUpdating = scr
    Application.Calculation = calc

    MsgBox "تم تنظيف العمود C ومعالجة 'عبد' .", vbInformation
End Sub

 

 

الود الثاني بدون مسافة: عبدالله

Sub CleanSpaces()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim cell As Range
    Dim t As String
    Dim reAbd As Object
    Dim scr As Boolean, calc As Long

    Set ws = ActiveSheet
    lastRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row

    scr = Application.ScreenUpdating
    calc = Application.Calculation
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Set reAbd = CreateObject("VBScript.RegExp")
    With reAbd
        .Global = True
        .IgnoreCase = False
        .Pattern = "عبد\s+(?=[اأإآء-يؤئبةتى])"
    End With

    For Each cell In ws.Range("C1:C" & lastRow)
        If Not cell.HasFormula Then
            If VarType(cell.Value) = vbString Then
                t = CStr(cell.Value)

                t = Replace(t, Chr(160), " ")
                t = Replace(t, vbTab, " ")
                t = Replace(t, ChrW(8206), "")
                t = Replace(t, ChrW(8207), "")

                t = Trim(t)

                Do While InStr(t, "  ") > 0
                    t = Replace(t, "  ", " ")
                Loop

                t = reAbd.Replace(t, "عبد")

                t = Trim(t)

                If cell.Value <> t Then cell.Value = t
            End If
        End If
    Next cell

    ' استرجاع الإعدادات
    Application.ScreenUpdating = scr
    Application.Calculation = calc

    MsgBox "تم تنظيف العمود C بالكامل وإزالة المسافات المكررة والمسافة بعد 'عبد'.", vbInformation
End Sub

 

تم تعديل منذ 2 ساعات بواسطه hegazee