Kelime Ayırma

[asi_kral]

Selamun Aleyküm Arkadaşlar
Elimde bir veri var bu veriyi kelimelere ayırmak istiyorum şöyle ki satırdaki karakter sayısı değişkenlik gösterebilir ayırt edeceğimiz satırda ise 50 karakter yazabiliyoruz. Ayırdığımız yerlerde böldüğümüzde kelimelerin bir kısmını yazmıyor.
Örnek kelime
"
Selamun Aleyküm Arkadaşlar
Elimde bir veri var bu veriyi kelimelere ayırmak istiyorum şöyle ki satırdaki karakter sayısı değişkenlik gösterebilir ayırt edeceğimiz satırda ise 50 karakter yazabiliyoruz. "

Bu veriyi Mid - Parçaal ile yaptığımızda bazı kelimeleri eksik almakta. Ben tam kelime olarak ayırmak istiyorum.
Örnek dosya ekliyorum.

 

[NBATMAN]

Merhaba,

şu kodları dener misiniz?

ayrıca dosyanızı da kodların bir buton ile çalışacak şekildeki halini de ekliyorum.

Sub SplitTextToCells()
    Dim inputText As String
    Dim maxLength As Integer
    Dim outputRow As Integer
    Dim currentPosition As Integer
    Dim spacePosition As Integer
    Dim segment As String
    
    ' A1 hücresindeki metni al
    inputText = Range("B1").Value
    maxLength = 50
    outputRow = 3 ' A2 hücresinden başlayacak
    currentPosition = 1
    
    Do While currentPosition <= Len(inputText)
        ' Kalan metnin uzunluğunu kontrol et
        If Len(Mid(inputText, currentPosition)) <= maxLength Then
            Range("B" & outputRow).Value = Mid(inputText, currentPosition)
            Exit Do
        End If
        
        ' 50 karaktere kadar olan kısmı al
        segment = Mid(inputText, currentPosition, maxLength)
        
        ' Son kelimeyi bul
        spacePosition = InStrRev(segment, " ")
        
        If spacePosition > 0 Then
            ' Kelimeleri son kelimeden önce kes
            Range("B" & outputRow).Value = Mid(segment, 1, spacePosition - 1)
            currentPosition = currentPosition + spacePosition
        Else
            ' Eğer hiç boşluk yoksa, tam olarak kes
            Range("B" & outputRow).Value = segment
            currentPosition = currentPosition + maxLength
        End If
        
        ' Sonraki satıra geç
        outputRow = outputRow + 1
        
        ' Eğer bir önceki satır 50 karakterden azsa, birleştirilecek alanı kontrol et
        If Len(Range("B" & outputRow - 1).Value) < maxLength Then
            Dim nextWord As String
            Dim nextSpace As Integer
            
            nextSpace = InStr(currentPosition, inputText, " ")
            If nextSpace > 0 Then
                nextWord = Mid(inputText, currentPosition, nextSpace - currentPosition)
                
                If Len(Range("B" & outputRow - 1).Value & " " & nextWord) <= maxLength Then
                    Range("B" & outputRow - 1).Value = Range("B" & outputRow - 1).Value & " " & nextWord
                    currentPosition = nextSpace + 1
                End If
            End If
        End If
    Loop
End Sub

 

[asi_kral]

Teşekkür ederim.