Excel kelimeleri hecelerine ayırma

M

mehmetaltin

Katılım
18 Kasım 2011
Mesajlar
398
Excel Vers. ve Dili
excel 2023 türkçe
Altın Üyelik Bitiş Tarihi
23.04.2018
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

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,863
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

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

C++: 
=METİNBÖL(C5;" ")
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
272
Excel Vers. ve Dili
Excel 2021 Türkçe
Heceleme için de deneyip sonucu paylaşabilir misiniz;

Kod: 
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
 
V

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
453
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
pitchoute' Alıntı:
Heceleme için de deneyip sonucu paylaşabilir misiniz;

Kod: 
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
Genişletmek için tıkla ...
yanlış ayırıyor hocam Volkan ismini Vo lkan diye ayırdı
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
272
Excel Vers. ve Dili
Excel 2021 Türkçe
Şöyle daha doğru ayırıyor olması gerekiyor;

Kod: 
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
 
V

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
453
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
pitchoute' Alıntı:
Şöyle daha doğru ayırıyor olması gerekiyor;

Kod: 
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
Genişletmek için tıkla ...
koddaki Return Kelime satırı kırmızı oluyor. İşe yaramadı.
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
272
Excel Vers. ve Dili
Excel 2021 Türkçe
Düzeltilmiş hali şu şekilde, tekraren denemesini yaparak gönderiyorum. Herhangi bir sorun kalmamış olması gerekiyor;

Kod: 
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
 
V

volki_112

Altın Üye
Katılım
29 Eylül 2023
Mesajlar
453
Excel Vers. ve Dili
2019 Türkçe
Altın Üyelik Bitiş Tarihi
13-12-2029
pitchoute' Alıntı:
Düzeltilmiş hali şu şekilde, tekraren denemesini yaparak gönderiyorum. Herhangi bir sorun kalmamış olması gerekiyor;

Kod: 
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
Genişletmek için tıkla ...
bu doğru sonuç veriyor hocam. elinize sağlık
 
P

pitchoute

Katılım
11 Temmuz 2024
Mesajlar
272
Excel Vers. ve Dili
Excel 2021 Türkçe
İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst