Tek hücredeki kelimeleri dağıtma

[feridici_genc]

İyi günler..
A1 Hücresinde bulunan bir cümledeki kelimeleri, boşlukları ve noktalama işaretlerini B15 hücresinden itibaren ayrı ayrı olarak hücrelere dağıtılması konusunda yardıma ihtiyacım var. Örnek olarak dosya ekledim.
Not: İlk satırın sonundaki nokta dan sonra alt enter ile satır başı yapıldı. Dolayısıyla istenen sonuç çıktısı da kelimeleri bir alt satırdan dağıtmaya başlaması gerekmektedir.

Teşekkürler.

 

[PLİNT]

Merhaba
Aşağıdaki gibi işinize yararsa bir deneyin.
http://s6.dosya.tc/server8/us7ph6/Deneme.zip.html

[SIZE="2"]Private Sub CommandButton1_Click()
Range("B15:B" & Rows.Count) = Empty
s = RetNonNum([a1])
s2 = [a1]
For x = 1 To Len(s)
If Left(s2, InStr(s2, Mid(s, x, 1))) <> Mid(s, x, 1) Then
Cells(14 + x + b, "B") = Left(s2, InStr(s2, Mid(s, x, 1)) - 1)
b = b + 1
Cells(14 + x + b, "B") = Mid(s, x, 1)
s2 = Right(s2, Len(s2) - InStr(s2, Mid(s, x, 1)))
Else
Cells(14 + x + b, "B") = Mid(s, x, 1)
s2 = Right(s2, Len(s2) - Len(Mid(s, x, 1)))
End If
Next
If s2 <> Empty Then Cells(14 + x + b, "B") = s2
End Sub


Function RetNonNum(AnyStr As String)
Dim RegEx
Set RegEx = CreateObject("vbscript.regexp")
With RegEx
.Global = True
 .IgnoreCase = False
.Pattern = "[\w+ı+ç+Ç+ö+Ö+Ü+ü+Ş+ş+Ğ+ğ+İ]"
End With
RetNonNum = RegEx.Replace(AnyStr, "")
Set RegEx = Nothing
End Function[/SIZE]

 

[Tevfik_Kursun]

Merhaba,
Ekli dosyada istediğiniz hem makro hem de fonksiyon ile yapılmıştır.
İyi çalışmalar

 

[feridici_genc]

Her ikinize de teşekkür ederim.
Boşlukları es geçerek yapılmış çalışmalar ama verdiğim örnekte ve açıklamada boşlukları ve noktaları da ayrı hücrelere parçalamak istiyorum.
Teşekkür ederim.

 

[Korhan Ayhan]

Merhaba,

Siz sadece örnek dosyanızda nokta işaretini ayrı hücrede göstermişsiniz.

Aşağıdaki kod örnek dosyanıza göre sonuç vermektedir.

Option Explicit

Sub CUMLELERI_PARCALARA_AYIR()
    Dim X As Long, Y As Integer, Z As Integer
    Dim VeriA As Variant, VeriB As Variant
    Dim Son As Long, Satir As Long, Sutun As Integer
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Son = Cells(Rows.Count, 1).End(3).Row
    Range("B1").Resize(1, Columns.Count - 1).EntireColumn.Clear
    Range("B1").Resize(1, Columns.Count - 1).ColumnWidth = 1
    Satir = 1
    Sutun = 2
    
    For X = 1 To Son
        If Cells(X, 1) <> "" Then
            VeriA = Split(Cells(X, 1).Value, Chr(10))
            For Y = 0 To UBound(VeriA)
                VeriB = Split(VeriA(Y), " ")
                For Z = 0 To UBound(VeriB)
                    If InStr(1, VeriB(Z), "..") = 0 And Right(VeriB(Z), 1) = "." Then
                        Cells(Satir, Sutun) = Mid(VeriB(Z), 1, Len(VeriB(Z)) - 1)
                        Sutun = Sutun + 2
                        Cells(Satir, Sutun) = "."
                        Sutun = Sutun + 2
                    Else
                        Cells(Satir, Sutun) = VeriB(Z)
                        Sutun = Sutun + 2
                    End If
                Next
                Satir = Satir + 1
                Sutun = 2
            Next
        End If
    Next

    Range("B1").Resize(1, Columns.Count - 1).EntireColumn.AutoFit

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub