Excel kelimeleri hecelerine ayırma

[mehmetaltin]

Arkadaşlar ekte verdiğim örnekteki gibi cümledeki kelimeleri başka hücrelere ayırma ve bir kelimenin hecelerini ayrı hücrelere nasıl ayırabilirim.

örnek

 

[Korhan Ayhan]

Merhaba,

İlk sorunuz için aşağıdaki formülü deneyebilirsiniz.

=METİNBÖL(C5;" ")

 

[volki_112]

Heceleme için de deneyip sonucu paylaşabilir misiniz;

Function TurkceHecele(kelime As String) As String
    Dim i As Integer
    Dim sonuc As String
    Dim sesliHarfler As String
    Dim sessizHarfler As String
    Dim hece As String
    Dim karakterSayisi As Integer
    Dim oncekiSesli As Boolean
    Dim sonrakiSesli As Boolean
   
    sesliHarfler = "aeıioöuüAEIİOÖUÜ"
    sessizHarfler = "bcçdfgğhjklmnprsştvyzBCÇDFGĞHJKLMNPRSŞTVYZ"
   
    sonuc = ""
    hece = ""
    karakterSayisi = Len(kelime)
    oncekiSesli = False
   
    For i = 1 To karakterSayisi
        Dim karakter As String
        karakter = Mid(kelime, i, 1)
       
        Dim sesliMi As Boolean
        sesliMi = (InStr(sesliHarfler, karakter) > 0)
       
        sonrakiSesli = False
        If i < karakterSayisi Then
            sonrakiSesli = (InStr(sesliHarfler, Mid(kelime, i + 1, 1)) > 0)
        End If
       
        hece = hece & karakter
       
        If sesliMi Then
            If oncekiSesli Then
                sonuc = sonuc & hece & "|"
                hece = ""
            ElseIf i = karakterSayisi Then
                sonuc = sonuc & hece & "|"
                hece = ""
            ElseIf sonrakiSesli Then
                sonuc = sonuc & hece & "|"
                hece = ""
            ElseIf i < karakterSayisi - 1 Then
                Dim sonraki1SessizMi As Boolean
                Dim sonraki2SessizMi As Boolean
                sonraki1SessizMi = (InStr(sessizHarfler, Mid(kelime, i + 1, 1)) > 0)
                sonraki2SessizMi = (InStr(sessizHarfler, Mid(kelime, i + 2, 1)) > 0)
               
                If sonraki1SessizMi And sonraki2SessizMi Then
                    sonuc = sonuc & hece & "|"
                    hece = ""
                End If
            End If
           
            oncekiSesli = True
        ElseIf i < karakterSayisi Then
            If oncekiSesli And sonrakiSesli Then
                sonuc = sonuc & hece & "|"
                hece = ""
            End If
           
            oncekiSesli = False
        End If
    Next i
   
    If hece <> "" Then
        sonuc = sonuc & hece
    End If
   
    If Right(sonuc, 1) = "|" Then
        sonuc = Left(sonuc, Len(sonuc) - 1)
    End If
   
    TurkceHecele = sonuc
End Function

Sub KelimeleriHecele()
    Dim secim As Range
    Dim hucre As Range
    Dim heceler As Variant
    Dim kelime As String
    Dim hecelenmisKelime As String
    Dim c As Integer
   
    On Error Resume Next
    Set secim = Application.InputBox("Hecelerine ayırmak istediğiniz kelimelerin olduğu hücreleri seçin:", "Heceleme", Type:=8)
    On Error GoTo 0
   
    If secim Is Nothing Then Exit Sub
   
    For Each hucre In secim
        kelime = Trim(hucre.Value)
        If kelime <> "" Then
            hecelenmisKelime = TurkceHecele(kelime)
           
            heceler = Split(hecelenmisKelime, "|")
           
            For c = 0 To UBound(heceler)
                hucre.Offset(0, c + 1).Value = heceler(c)
            Next c
        End If
    Next hucre
   
    MsgBox "Heceleme tamamlandı.", vbInformation
End Sub

yanlış ayırıyor hocam Volkan ismini Vo lkan diye ayırdı

 

[volki_112]

Şöyle daha doğru ayırıyor olması gerekiyor;

Function TurkceHecele(kelime As String) As String
    Dim i As Integer
    Dim sonuc As String
    Dim sesliHarfler As String
    Dim sessizHarfler As String
    Dim karakterSayisi As Integer
   
    sesliHarfler = "aeıioöuüAEIİOÖUÜ"
    sessizHarfler = "bcçdfgğhjklmnprsştvyzBCÇDFGĞHJKLMNPRSŞTVYZ"
   
    sonuc = ""
    karakterSayisi = Len(kelime)
   
    If karakterSayisi <= 2 Then
        Return kelime
    End If
   
    Dim heceIndeksleri As New Collection
    Dim sesliPozisyonlari() As Integer
    Dim sesliSayisi As Integer
   
    sesliSayisi = 0
    ReDim sesliPozisyonlari(karakterSayisi)
   
    For i = 1 To karakterSayisi
        If InStr(sesliHarfler, Mid(kelime, i, 1)) > 0 Then
            sesliSayisi = sesliSayisi + 1
            sesliPozisyonlari(sesliSayisi) = i
        End If
    Next i
   
    If sesliSayisi = 0 Then
        Return kelime
    End If
   
    For i = 1 To sesliSayisi - 1
        Dim simdikiSesliPoz As Integer
        Dim sonrakiSesliPoz As Integer
       
        simdikiSesliPoz = sesliPozisyonlari(i)
        sonrakiSesliPoz = sesliPozisyonlari(i + 1)
       
        Dim aralikUzunlugu As Integer
        aralikUzunlugu = sonrakiSesliPoz - simdikiSesliPoz
       
        If aralikUzunlugu = 1 Then
            On Error Resume Next
            heceIndeksleri.Add simdikiSesliPoz, CStr(simdikiSesliPoz)
            On Error GoTo 0
        ElseIf aralikUzunlugu = 2 Then
            On Error Resume Next
            heceIndeksleri.Add simdikiSesliPoz, CStr(simdikiSesliPoz)
            On Error GoTo 0
        ElseIf aralikUzunlugu = 3 Then
            On Error Resume Next
            heceIndeksleri.Add simdikiSesliPoz + 1, CStr(simdikiSesliPoz + 1)
            On Error GoTo 0
        ElseIf aralikUzunlugu = 4 Then
            On Error Resume Next
            heceIndeksleri.Add simdikiSesliPoz + 2, CStr(simdikiSesliPoz + 2)
            On Error GoTo 0
        Else
            On Error Resume Next
            heceIndeksleri.Add simdikiSesliPoz + 2, CStr(simdikiSesliPoz + 2)
            On Error GoTo 0
        End If
    Next i
   
    Dim oncekiIndeks As Integer
    oncekiIndeks = 1
   
    Dim indeksListe() As Integer
    Dim indeksSayisi As Integer
   
    indeksSayisi = heceIndeksleri.Count
    If indeksSayisi > 0 Then
        ReDim indeksListe(indeksSayisi)
       
        For i = 1 To indeksSayisi
            indeksListe(i - 1) = heceIndeksleri(i)
        Next i
       
        Call SiralaIndeksler(indeksListe)
       
        For i = 0 To indeksSayisi - 1
            sonuc = sonuc & Mid(kelime, oncekiIndeks, indeksListe(i) - oncekiIndeks + 1) & "|"
            oncekiIndeks = indeksListe(i) + 1
        Next i
    End If
   
    sonuc = sonuc & Mid(kelime, oncekiIndeks)
   
    If Right(sonuc, 1) = "|" Then
        sonuc = Left(sonuc, Len(sonuc) - 1)
    End If
   
    TurkceHecele = sonuc
End Function

Private Sub SiralaIndeksler(indeksler() As Integer)
    Dim i As Integer, j As Integer
    Dim gecici As Integer
    Dim n As Integer
   
    n = UBound(indeksler)
   
    For i = 0 To n - 1
        For j = 0 To n - i - 1
            If indeksler(j) > indeksler(j + 1) Then
                gecici = indeksler(j)
                indeksler(j) = indeksler(j + 1)
                indeksler(j + 1) = gecici
            End If
        Next j
    Next i
End Sub

Sub KelimeleriHecele()
    Dim secim As Range
    Dim hucre As Range
    Dim heceler As Variant
    Dim kelime As String
    Dim hecelenmisKelime As String
    Dim c As Integer
   
    On Error Resume Next
    Set secim = Application.InputBox("Hecelerine ayırmak istediğiniz kelimelerin olduğu hücreleri seçin:", "Heceleme", Type:=8)
    On Error GoTo 0
   
    If secim Is Nothing Then Exit Sub
   
    For Each hucre In secim
        kelime = Trim(hucre.Value)
        If kelime <> "" Then
            hecelenmisKelime = TurkceHecele(kelime)
           
            heceler = Split(hecelenmisKelime, "|")
           
            For c = 0 To UBound(heceler)
                hucre.Offset(0, c + 1).Value = heceler(c)
            Next c
        End If
    Next hucre
   
    MsgBox "Heceleme tamamlandı.", vbInformation
End Sub

Function KelimeBol(kelime As String, maxUzunluk As Integer) As String
    If Len(kelime) <= maxUzunluk Then
        Return kelime
    End If
   
    Dim hecelenmisKelime As String
    Dim heceler As Variant
    Dim sonuc As String
    Dim satir As String
    Dim i As Integer
   
    hecelenmisKelime = TurkceHecele(kelime)
    heceler = Split(hecelenmisKelime, "|")
   
    sonuc = ""
    satir = ""
   
    For i = 0 To UBound(heceler)
        If Len(satir) + Len(heceler(i)) > maxUzunluk Then
            If Len(satir) > 0 Then
                sonuc = sonuc & satir & "-" & vbCrLf
            End If
            satir = heceler(i)
        Else
            satir = satir & heceler(i)
        End If
    Next i
   
    If Len(satir) > 0 Then
        sonuc = sonuc & satir
    End If
   
    KelimeBol = sonuc
End Function

koddaki Return Kelime satırı kırmızı oluyor. İşe yaramadı.

 

[volki_112]

Düzeltilmiş hali şu şekilde, tekraren denemesini yaparak gönderiyorum. Herhangi bir sorun kalmamış olması gerekiyor;

Option Explicit

Sub TekTiklaHeceleme()
    Dim seciliHucre As Range
    Dim kelime As String
    Dim heceler As Variant
    Dim i As Integer
   
    If Selection.Cells.Count = 0 Then
        MsgBox "Lütfen hecelemek istediğiniz kelime veya kelimelerin olduğu hücreleri seçin.", vbExclamation
        Exit Sub
    End If
   
    Selection.Offset(0, 1).Resize(Selection.Rows.Count, 10).ClearContents
   
    For Each seciliHucre In Selection
        kelime = Trim(seciliHucre.Value)
       
        If Len(kelime) > 0 Then
            heceler = HecelereBol(kelime)
           
            For i = 0 To UBound(heceler)
                seciliHucre.Offset(0, i + 1).Value = heceler(i)
            Next i
        End If
    Next seciliHucre
   
    MsgBox "Heceleme işlemi tamamlandı.", vbInformation
End Sub

Function HecelereBol(kelime As String) As Variant
    Const SesliHarfler As String = "aeıioöuüAEIİOÖUÜ"
   
    Dim i As Integer
    Dim j As Integer
    Dim heceler As Collection
    Dim mevcutHece As String
    Dim harfSayisi As Long
   
    Set heceler = New Collection
    harfSayisi = Len(kelime)
   
    If harfSayisi = 0 Then
        HecelereBol = Array("")
        Exit Function
    End If
   
    i = 1
    mevcutHece = ""
   
    Do While i <= harfSayisi
        Dim simdikiHarf As String
        simdikiHarf = Mid(kelime, i, 1)
        mevcutHece = mevcutHece & simdikiHarf
       
        If i = harfSayisi Then
            If Len(mevcutHece) > 0 Then
                heceler.Add mevcutHece
            End If
            Exit Do
        End If
       
        Dim simdikiSesliMi As Boolean
        simdikiSesliMi = (InStr(SesliHarfler, simdikiHarf) > 0)
       
        Dim sonrakiHarf As String
        sonrakiHarf = Mid(kelime, i + 1, 1)
       
        Dim sonrakiSesliMi As Boolean
        sonrakiSesliMi = (InStr(SesliHarfler, sonrakiHarf) > 0)
       
        If simdikiSesliMi And sonrakiSesliMi Then
            heceler.Add mevcutHece
            mevcutHece = ""
       
        ElseIf simdikiSesliMi And Not sonrakiSesliMi And i + 2 <= harfSayisi Then
            Dim sonrakiHarf2 As String
            sonrakiHarf2 = Mid(kelime, i + 2, 1)
           
            If InStr(SesliHarfler, sonrakiHarf2) > 0 Then
                heceler.Add mevcutHece
                mevcutHece = ""
            End If
       
        ElseIf Not simdikiSesliMi And sonrakiSesliMi And Len(mevcutHece) > 1 Then
            Dim sesliVarMi As Boolean
            sesliVarMi = False
           
            For j = 1 To Len(mevcutHece) - 1
                If InStr(SesliHarfler, Mid(mevcutHece, j, 1)) > 0 Then
                    sesliVarMi = True
                    Exit For
                End If
            Next j
           
            If sesliVarMi Then
                heceler.Add Left(mevcutHece, Len(mevcutHece) - 1)
                mevcutHece = Right(mevcutHece, 1)
            End If
        End If
       
        i = i + 1
    Loop
   
    Dim sonuc() As String
    ReDim sonuc(heceler.Count - 1)
   
    For i = 1 To heceler.Count
        sonuc(i - 1) = heceler(i)
    Next i
   
    HecelereBol = sonuc
End Function

bu doğru sonuç veriyor hocam. elinize sağlık