Hücre biçimi bozulmadan boşlukları silme

[tahsinanarat]

Göndermiş olduğum örnek dosyamda hücre biçimi bozulmadan (renkli kelimeler kaybolmadan) kelimeler arasındaki birden fazla boşlukları silmek istiyorum. Bulduğum diğer boşluk silme kodlarını denediğimde hücredeki bütün kelimeler mavi oluyor. Yardımcı olabilecek arkadaşlarıma şimdeden teşekkür ederim.

 

[tahsinanarat]

Sanıyorum biraz zor görünüyor, yabancı sitelerde de araştırma yaptım ama pek bir şey bulamadım.

 

[tahsinanarat]

Konuyu son bir kez daha gündeme getireyim dedim, belki olayı bilip de görmeyen uzman arkadaşlarımız olabilir diye.

 

[Korhan Ayhan]

Selamlar,

Aşağıdaki kodu denermisiniz. Veri sayınız fazla ise işlem süresi uzayabilir. Yeni liste B sütununa oluşturulur.

Option Explicit
 
Sub BİÇİMİ_BOZMADAN_BOŞLUKLARI_SİL()
    Dim X1 As Long, X2 As Integer, X3 As Integer, X4 As Integer
    Dim Kelime1 As Variant, Kelime2 As Variant, Say As Integer
    
    Application.ScreenUpdating = False
    
    Columns(2).Clear
    
    For X1 = 1 To Range("A65536").End(3).Row
        Kelime1 = Split(Cells(X1, 1), " ")
        Cells(X1, 2) = WorksheetFunction.Trim(Cells(X1, 1))
        Kelime2 = Split(Cells(X1, 2), " ")
        Say = 0
        For X2 = 0 To UBound(Kelime1)
            If Kelime1(X2) <> " " Then
        
            For X3 = 0 To UBound(Kelime2)
                If Kelime1(X2) = Kelime2(X3) Then
                    For X4 = 1 To Len(Kelime2(X3))
                        With Cells(X1, 2).Characters(Start:=Say + X4, Length:=1)
                            .Font.ColorIndex = Cells(X1, 1).Characters(Start:=Say + X4, Length:=1).Font.ColorIndex
                            .Font.Bold = Cells(X1, 1).Characters(Start:=Say + X4, Length:=1).Font.Bold
                            .Font.Size = Cells(X1, 1).Characters(Start:=Say + X4, Length:=1).Font.Size
                            .Font.Name = Cells(X1, 1).Characters(Start:=Say + X4, Length:=1).Font.Name
                        End With
                    Next
                    Say = X4
                    GoTo Devam
                End If
            Next
            
            End If
Devam:
        Next
    Next
    
    Application.ScreenUpdating = True
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[tahsinanarat]

Korhan Hocam elinize sağlık, çok güzel olmuş. Teşekkür ederim sağolun.