Metinden KTF ile şartları taşıyan ilk üç harfi al?

hsayar · 17 Ocak 2011

ADANA
ANKARA
ÇANAKKALE
SİİRT

VAN

gibi metinlerimiz var diyelim. Bunkar için anlamlı üç harfli kısaltmalar için nasıl bir fonksiyon yazılmlaıdır?
Şartlar;

1) Metnin ilk harfi ne ise sonucun ilk harfide ol olacak {A, A, Ç, S}
2) Metnin İkinci Harfli, ünlü harf ise (a, e, ı, i, o,ö, u, ü) sonucun ikinci Harfi, bir sonra gelen sessiz harf. (üçüncü harf sesli ise yine kontrol et) {D, N, N, R}
3) Metnin üçüncü Harfli, ünlü harf ise (a, e, ı, i, o,ö, u, ü) sonuçta metnin kaçıncı harfi kullanıldı ise , bir sonra gelen sessiz harf. (x. harf sesli ise yine kontrol et) {N, K, K, T}

özel durum: Metin Zaten üç harfli ise olduğu gibi al.

Korhan Ayhan · 17 Ocak 2011

Selamlar,

Ekteki örnek dosyayı incelermisiniz.

Kullanılan kod; (Boş bir modüle uygulayınız.)

Hücrede kullanım şekli;

Kod:

[B][COLOR=blue]=MKIRP(A1)[/COLOR][/B]

Kod:

Option Explicit
Option Base 1
 
Function MKIRP(Hücre As Range) As String
    Dim X As Integer, Y As Integer, Sesli_Harfler(), Sessiz_Harfler()
    
    Application.Volatile True
    
    Sesli_Harfler = Array("A", "E", "I", "İ", "O", "Ö", "U", "Ü")
    Sessiz_Harfler = Array("B", "C", "Ç", "D", "F", "G", "Ğ", "H", "J", "K", "L", "M", "N", "P", "R", "S", "Ş", "T", "V", "Y", "Z")
    
    If Len(Hücre) = 3 Then
        MKIRP = UCase(Replace(Replace(Hücre, "ı", "I"), "i", "İ"))
        Exit Function
    End If
    
    MKIRP = Left(Hücre, 1)
    
    For X = 2 To Len(Hücre)
        If Len(MKIRP) = 3 Then Exit Function
        For Y = 1 To UBound(Sessiz_Harfler())
            If Mid(UCase(Replace(Replace(Hücre, "ı", "I"), "i", "İ")), X, 1) = Sessiz_Harfler(Y) Then
                MKIRP = MKIRP & Sessiz_Harfler(Y)
                Exit For
            End If
        Next
    Next
    
    If Len(MKIRP) = 2 Then
        X = 1
        For Y = UBound(Sesli_Harfler()) To 1 Step -1
            If Mid(StrReverse(UCase(Replace(Replace(Hücre, "ı", "I"), "i", "İ"))), X, 1) = Sesli_Harfler(Y) Then
                MKIRP = MKIRP & Sesli_Harfler(Y)
                X = X + 1
                Exit For
            End If
        Next
    End If
End Function

dost · 17 Ocak 2011

Merhaba,

Kod:

Sub Test()
    Dim MyList As String
    Dim MyCell As Range
    Dim MyDizi()
    
    On Error Resume Next
    MyDizi = Array("A", "E", "I", "İ", "O", "Ö", "U", "U", "a", "e", "ı", "i", "o", "ö", "u", "ü")
    
    For Each MyCell In Selection 'Selection yerine alan belirleyebilirsin.
        If Len(MyCell) = 3 Then
            MyCell.Offset(0, 1) = MyCell
        Else
            MyList = Left(MyCell, 1)
            say = 1
            For i = 2 To Len(MyCell)
               deger = Mid(MyCell, i, 1)
               If WorksheetFunction.Match(Mid(MyCell, i, 1), MyDizi(), 0) = 0 Then _
                    MyList = MyList & Mid(MyCell, i, 1): say = say + 1
               If say = 3 Then say = 0: MyCell.Offset(0, 1) = MyList: Exit For
            Next i
        End If
    Next
    
End Sub

excel03 · 17 Ocak 2011

merhaba;
alternatif.

Kod:

Function Kısalt(ByVal kelime As String) As String
Dim DoğruHarf As Boolean
DoğruHarf = True
If Len(kelime) = 3 Then
Kısalt = kelime
Exit Function
End If
İlkHarf = Mid(kelime, 1, 1)
For j = 2 To Len(kelime)
20:
C = Mid(kelime, j, 1)
GoSub 10
If DoğruHarf = False Then
j = j + 1
GoTo 20
End If
If a = 1 Then y = C
If a = 2 Then z = C
If a = 2 Then Exit For
Next
GoTo 30
10:     
        Select Case C
        Case "A", "E", "I", "İ", "O", "Ö", "U", "Ü"
        DoğruHarf = False
        Case Else
        DoğruHarf = True
        a = a + 1
        End Select
Return            
30:
Kısalt = İlkHarf & y & z
End Function

dost · 17 Ocak 2011

Merhaba,

Sayın Korhan Ayhan cevabı göndermiş, görmemişim. Kusura bakmasın.

Ayrıca KTF istenmiş onu da görememişim.

Ancak fonksiyonu hazırlamıştım o da boşa gitmesin.

Kod:

Function UcHarfAyir(Hucre As Range) As String

    Dim MyList As String
    Dim MyDizi()
    
    On Error Resume Next
    MyDizi = Array("A", "E", "I", "İ", "O", "Ö", "U", "U", "a", "e", "ı", "i", "o", "ö", "u", "ü")
    
    If Len(Hucre) = 3 Then
        UcHarfAyir = Hucre
    Else
        MyList = Left(Hucre, 1)
        say = 1
        For i = 2 To Len(Hucre)
           If WorksheetFunction.Match(Mid(Hucre, i, 1), MyDizi(), 0) = 0 Then _
                MyList = MyList & Mid(Hucre, i, 1): say = say + 1
           If say = 3 Then say = 0: UcHarfAyir = MyList: Exit For
        Next i
    End If
    
End Function

Korhan Ayhan · 17 Ocak 2011

Selamlar,

Sn. excel03,

Sizin KTF kodunuz hep soldan 3 karakteri alıyor. Bu durumda aynı işlemi =SOLDAN(A1;3) gibi bir fonksiyonlada yapabiliriz. Yani KTF kullanmak bu durumda gereksiz oluyor.

Sn. dost,

Alternatif çözümler açısından tüm üyelerimiz hazırladığı çözümleri paylaşabilir.

Sizin çözümünüzde ise BOLU ve RİZE illerinde problem oluşuyor. Fonksiyon boş değer döndürüyor. Diğer illerde problem görünmüyor.

hsayar · 17 Ocak 2011

Korhan Hacam Alaknıza Teşekkür ederim.
kodlar gayet güzel ben her zaman range üzerinden kollanmayacağım için as range refransının iptal ettim.

Şu an için değil ama yarın için ingilizce durumuda gerekecek. bunu nasıl gelitirebiliriz. Türkçe İngilizce uyumlu olarak.
YAda her dil için ayrıca mı yazmalıyız?

Örneği
mümkünse Türk, İngiliz ve Azerbeycan Alfabasilerine göre geliştrebilirmiyiz.
Azerbeycan Alfabesinde seslilere Əə eklenir ama vba da nasıl gözükür bilemem

İki dil için sessizlere (w,x,q eklenir)

Kod:

Function Uc_Harfli_KodUret(Metin) As String
'KorhanAyhan@Excel.web.tr
    
    Dim X As Integer, Y As Integer, Sesli_Harfler(), Sessiz_Harfler()
    
    Application.Volatile True
    
    Sesli_Harfler = Array("A", "E", "I", "İ", "O", "Ö", "U", "Ü")
    Sessiz_Harfler = Array("B", "C", "Ç", "D", "F", "G", "Ğ", "H", "J", "K", "L", "M", "N", "P", "R", "S", "Ş", "T", "V", "Y", "Z")

'    Sessiz_Harfler = Array("B", "C", "Ç", "D", "F", "G", "Ğ", "H", "J", "K", "L", "M", "N", "P", "R", "S", "Ş", "T", "V", "Y", "Z", "W", "X", "Q")
    
    If Len(Metin) = 3 Then
        Uc_Harfli_KodUret = UCase(Replace(Replace(Metin, "ı", "I"), "i", "İ"))
        Exit Function
    End If
    
    Uc_Harfli_KodUret = Left(Metin, 1)
    
    For X = 2 To Len(Metin)
        If Len(Uc_Harfli_KodUret) = 3 Then Exit Function
        For Y = 1 To UBound(Sessiz_Harfler())
            If Mid(UCase(Replace(Replace(Metin, "ı", "I"), "i", "İ")), X, 1) = Sessiz_Harfler(Y) Then
                Uc_Harfli_KodUret = Uc_Harfli_KodUret & Sessiz_Harfler(Y)
                Exit For
            End If
        Next
    Next
    
    If Len(Uc_Harfli_KodUret) = 2 Then
        X = 1
        For Y = UBound(Sesli_Harfler()) To 1 Step -1
            If Mid(StrReverse(UCase(Replace(Replace(Metin, "ı", "I"), "i", "İ"))), X, 1) = Sesli_Harfler(Y) Then
                Uc_Harfli_KodUret = Uc_Harfli_KodUret & Sesli_Harfler(Y)
                X = X + 1
                Exit For
            End If
        Next
    End If
End Function

dost · 17 Ocak 2011

Korhan Ayhan' Alıntı:
Selamlar,

Sn. dost,

Alternatif çözümler açısından tüm üyelerimiz hazırladığı çözümleri paylaşabilir.

Sizin çözümünüzde ise BOLU ve RİZE illerinde problem oluşuyor. Fonksiyon boş değer döndürüyor. Diğer illerde problem görünmüyor.

Sayın Ayhan,

Ben kelimenin 1.harfinden sonra 2 sessiz harf yoksa boş döndürüyorum. Soruyu o şekilde anlamıştım. Ancak; kesinlikle 3 harfli kısaltma olacaksa, kodun ilgili bölümünü aaşağıdaki şekilde değiştirmek gerekir.

Kolay gelsin.

Kod:

         For i = 2 To Len(Hucre)
           If WorksheetFunction.Match(Mid(Hucre, i, 1), MyDizi(), 0) = 0 Then _
                MyList = MyList & Mid(Hucre, i, 1): say = say + 1
           If Len(Hucre) - i = 2 And say = 1 Then MyList = MyList & Right(Hucre, 2): say = 3
           If Len(Hucre) - i = 1 And say = 2 Then MyList = MyList & Right(Hucre, 1): say = 3
           If say = 3 Then say = 0: UcHarfAyir = MyList: Exit For
        Next i

dost · 17 Ocak 2011

hsayar' Alıntı:
Korhan Hacam Alaknıza Teşekkür ederim.
kodlar gayet güzel ben her zaman range üzerinden kollanmayacağım için as range refransının iptal ettim.

............

Sayın hsayar,

Sayın Ayhan bu forumda herkese yardım etmeye çalışan değerli bir arkadaşımız, bu yardımlarından dolayı herkes adına kendilerine ben de teşekkür ederim.

Ancak; sorduğunuz soruya zaman ayırıp cevap veren iki kişi daha var. Bu şekilde davranıldığında ben ve excel03 arkadaşımız size yardım etmenin mutluluğunu yaşayamayacağız.

Bu konuda deneyimli bir üye olarak gerekli hassasiyeti göstermenizi rica ederim.

Saygılarımla...

hsayar · 17 Ocak 2011

dost' Alıntı:
Sayın hsayar,

Sayın Ayhan bu forumda herkese yardım etmeye çalışan değerli bir arkadaşımız, bu yardımlarından dolayı herkes adına kendilerine ben de teşekkür ederim.

Ancak; sorduğunuz soruya zaman ayırıp cevap veren iki kişi daha var. Bu şekilde davranıldığında ben ve excel03 arkadaşımız size yardım etmenin mutluluğunu yaşayamayacağız.

Bu konuda deneyimli bir üye olarak gerekli hassasiyeti göstermenizi rica ederim.

Saygılarımla...

Sn. Dost yardım çabanıza teşekkür ederim. ben kodlarını kullandığımı belirtmek için sadece korhen beye teşekkür ettim. Sizleri ihmal etttiğim için özür dilerim.

hsayar · 17 Ocak 2011

Sn. Dost 5 nolu mesajınızda 8 nolu mesajınızdaki düzeltmeyi uygulayınca Türkçe ve İngilizce Kelimelerin kısa kodunu alabiliyorum. Azerbeycan Türkçesi için seslilere Əə harfi nasıl ilave edilecektir?

dost · 17 Ocak 2011

Sayın hsayar,

Nezaketiniz ve olgunluğunuz için teşekkür ederim.

Kolay gelsin.

excel03 · 17 Ocak 2011

Korhan Ayhan' Alıntı:
Selamlar,

Sn. excel03,

Sizin KTF kodunuz hep soldan 3 karakteri alıyor. Bu durumda aynı işlemi =SOLDAN(A1;3) gibi bir fonksiyonlada yapabiliriz. Yani KTF kullanmak bu durumda gereksiz oluyor.
.........

kodlar gözden geçirildi.Büyük harfle girilen değerler döndürülmekte. (idi)

şimdi tüm değişkenler döndürülüyor.

Kod:

Function Kısalt(kelime) As String
Dim DoğruHarf As Boolean

kelime = UCase(Replace(Replace(kelime, "ı", "I"), "i", "İ"))
DoğruHarf = True

If Len(kelime) = 3 Then
Kısalt = kelime
Exit Function
End If
İlkHarf = Mid(kelime, 1, 1)

For j = 2 To Len(kelime)
20:
C = Mid(kelime, j, 1)
GoSub 10
If DoğruHarf = False Then
j = j + 1
GoTo 20
End If
If a = 1 Then Y = C
If a = 2 Then z = C
If a = 2 Then Exit For
Next
GoTo 30
10:
        Select Case C
        Case "A", "E", "I", "İ", "O", "Ö", "U", "Ü"
        DoğruHarf = False
        Case Else
        DoğruHarf = True
        a = a + 1
        End Select
Return
30:
Kısalt = İlkHarf & Y & z
End Function

hsayar · 18 Ocak 2011

inebolu> İNB olmalıdır.

excel03 · 18 Ocak 2011

hsayar' Alıntı:
inebolu> İNB olmalıdır.

doğru. "inebolu" kelimesinin kısa hâli İNB olmalıdır.Ancak Korhan Ayhan'ın konuyla ilgili yüklediği *.xls dosyasında bu sonuç üretilmiyor.

ilgili linkler:

konu:
http://www.excel.web.tr/f48/metinden-ktf-ile-artlary-ta-yyan-ilk-uc-t94204.html

dosya:
http://www.excel.web.tr/attachment.php?attachmentid=102513&d=1295255614

Korhan Ayhan · 18 Ocak 2011

Selamlar,

Sn. excel03,

Benim eklediğim dosyada bahsettiğiniz şekilde bir sorun yok. Sadece küçük "i" harfini büyük harfe çevirmiyordu. Onuda ekteki dosyada düzelttim. İncelermisiniz.

Kodun son hali;

Kod:

Option Explicit
Option Base 1
 
Function MKIRP(Hücre As Range) As String
    Dim X As Integer, Y As Integer, Sesli_Harfler(), Sessiz_Harfler()
    
    Application.Volatile True
    
    Sesli_Harfler = Array("A", "E", "I", "İ", "O", "Ö", "U", "Ü")
    Sessiz_Harfler = Array("B", "C", "Ç", "D", "F", "G", "Ğ", "H", "J", "K", "L", "M", "N", "P", "R", "S", "Ş", "T", "V", "Y", "Z")
    
    If Len(Hücre) = 3 Then
        MKIRP = UCase(Replace(Replace(Hücre, "ı", "I"), "i", "İ"))
        Exit Function
    End If
    
    MKIRP = Left(Hücre, 1)
    
    For X = 2 To Len(Hücre)
        If Len(MKIRP) = 3 Then
            MKIRP = UCase(Replace(Replace(MKIRP, "ı", "I"), "i", "İ"))
            Exit Function
        End If
        For Y = 1 To UBound(Sessiz_Harfler())
            If Mid(UCase(Replace(Replace(Hücre, "ı", "I"), "i", "İ")), X, 1) = Sessiz_Harfler(Y) Then
                MKIRP = MKIRP & Sessiz_Harfler(Y)
                MKIRP = UCase(Replace(Replace(MKIRP, "ı", "I"), "i", "İ"))
                Exit For
            End If
        Next
    Next
    
    If Len(MKIRP) = 2 Then
        X = 1
        For Y = UBound(Sesli_Harfler()) To 1 Step -1
            If Mid(StrReverse(UCase(Replace(Replace(Hücre, "ı", "I"), "i", "İ"))), X, 1) = Sesli_Harfler(Y) Then
                MKIRP = MKIRP & Sesli_Harfler(Y)
                MKIRP = UCase(Replace(Replace(MKIRP, "ı", "I"), "i", "İ"))
                X = X + 1
                Exit For
            End If
        Next
    End If
End Function

Metinden KTF ile şartları taşıyan ilk üç harfi al?

hsayar

Korhan Ayhan

Administrator

Ekli dosyalar

dost

excel03

dost

Korhan Ayhan

Administrator

hsayar

dost

dost

hsayar

hsayar

dost

excel03

hsayar

excel03

Korhan Ayhan

Administrator

Ekli dosyalar