Makro Kodunu İstenilen Hücrede Çalıştırma

[Golyaka07]

Merhaba herkese kolay gelsin
Private Sub Worksheet_Change(ByVal Target As Range)
' B5 hücresi değiştiğinde çalışır
If Not Intersect(Target, Range("B5")) Is Nothing Then
' B5 hücresi doluysa EkiEkle prosedürünü çağır
If Len(Range("B5").Value) > 0 Then
EkiEkle
End If
End If
End Sub
Sub EkiEkle()
' B5 hücresinden şehir isimlerini al
Dim hücreB5 As Range
Set hücreB5 = Range("B5")

' Şehir isimlerini düzenle ve B6 hücresine yaz
Range("B6").Value = DuzenleEki(hücreB5.Value)
End Sub



Function DuzenleEki(sehirler As String) As String
' Kalın sesli harfler
Dim kalın_sesli_harfler As String
kalın_sesli_harfler = "aıou"

' İnce sesli harfler
Dim ince_sesli_harfler As String
ince_sesli_harfler = "eiöü"

' - işaretine göre şehir isimlerini ayır
Dim s As Variant
s = Split(sehirler, " - ")

' Birinci şehir adı
Dim sehir1 As String
sehir1 = Trim(s(0)) ' Boşlukları temizle

' Birinci şehir'in son iki karakterini kontrol et ve eki ekle
Dim sonIkiKarakter1 As String
sonIkiKarakter1 = Mid(sehir1, Len(sehir1) - 1, 2)

If InStr(kalın_sesli_harfler, Mid(sonIkiKarakter1, 1, 1)) > 0 Then
sehir1 = sehir1 & "'dan"
ElseIf InStr(ince_sesli_harfler, Mid(sonIkiKarakter1, 1, 1)) > 0 Then
sehir1 = sehir1 & "'den"
End If

If InStr(kalın_sesli_harfler, Mid(sonIkiKarakter1, 2, 1)) > 0 Then
sehir1 = sehir1 & "'dan"
ElseIf InStr(ince_sesli_harfler, Mid(sonIkiKarakter1, 2, 1)) > 0 Then
sehir1 = sehir1 & "'den"
End If

' İkinci şehir adı
Dim sehir2 As String
sehir2 = Trim(s(1)) ' Boşlukları temizle

' İkinci şehir'in son iki karakterini kontrol et ve eki ekle
Dim sonIkiKarakter2 As String
sonIkiKarakter2 = Mid(sehir2, Len(sehir2) - 1, 2)

If InStr(kalın_sesli_harfler, Mid(sonIkiKarakter2, 2, 1)) > 0 Then
sehir2 = sehir2 & "'ya"
ElseIf InStr(ince_sesli_harfler, Mid(sonIkiKarakter2, 2, 1)) > 0 Then
sehir2 = sehir2 & "'ye"
End If

If Mid(sehir2, Len(sehir2), 1) = "s" Then
sehir2 = sehir2 & "'e"
End If

' Düzenlenmiş şehir isimlerini birleştir ve geri döndür
DuzenleEki = sehir1 & " - " & sehir2
End Function
Elimde böyle bir kod var. Bu kodda b5 hücresinde aralarında - işareti bulunan " Samsun - Ankara " iki şehir ismine ayrılma ve yönelme ekleri eklenerek b6 hücresine yazılmaktadır. Ben b6 hücresi yerine istediğim hücreye bu kodu yazdıramıyorum. Örneğin a2 hücremde bir metin var ve metin içerisine b5te bulunan şehir isimlerine ayrılma ve yönelme ekleri eklenerek yazmasını istiyorum. a2 hücresine =ekiekle(b5) yazdığımda aktif olmasını istiyorum. (Not: VBA kodları konusunda deneyimli değilim öğrenmeye yeni başladım)

 

[HücrelereFısıldayanAdam]

Bence soru net anlaşılmıyor.. excel dosyası yükleyin isterseniz.

 

[Golyaka07]

Bence soru net anlaşılmıyor.. excel dosyası yükleyin isterseniz.

b5 hücresinde "Samsun - Ankara" metni , a2 hücresinde "21.12.2023 tarihinde ....... yaptığım yolculuk." metni ve modul kısmından eklediğim bu formül var başka birşey yokki elimde olan. Formül sayesinde b5 hücresinde yer alan Samsun - Ankara metni sadece b6 hücresinde Samsun'dan Ankara'ya olarak değişmektedir. Elimizde olanlar bundan ibaret. ben b6 hücresi yerine a2 hücresine bunu eklemek istiyorum ancak a2 hücresinde de "21.12.2023 tarihinde ....... yaptığım yolculuk." metni bulunuyor ve ..... kısmına Samsun'dan Ankara'ya ifadesi gelsin istiyorum.

 

[necati]

Merhaba, kendi fonksiyonunuzu kullanarak:

="21.12.2023 tarihinde " & DuzenleEki(B5) &" yaptığım yolculuk."

Ek tavsiye şu satırı:
s = Split(sehirler, " - ")
şu şekilde yazmak kullanıcı yazım hatasını gidermek için daha mantıklı.
s = Split(sehirler, "-")

 

[BaY_KaPTaN]

b5 hücresinde "Samsun - Ankara" metni , a2 hücresinde "21.12.2023 tarihinde ....... yaptığım yolculuk." metni ve modul kısmından eklediğim bu formül var başka birşey yokki elimde olan. Formül sayesinde b5 hücresinde yer alan Samsun - Ankara metni sadece b6 hücresinde Samsun'dan Ankara'ya olarak değişmektedir. Elimizde olanlar bundan ibaret. ben b6 hücresi yerine a2 hücresine bunu eklemek istiyorum ancak a2 hücresinde de "21.12.2023 tarihinde ....... yaptığım yolculuk." metni bulunuyor ve ..... kısmına Samsun'dan Ankara'ya ifadesi gelsin istiyorum.

Soru değişik geldi, Yanlış anlamadıysam eğer B6 yerine A2'ye yazsın istiyorsunuz.

Kodların arasında aşağıdaki kod yerine;

' Şehir isimlerini düzenle ve B6 hücresine yaz
Range("B6").Value = DuzenleEki(hücreB5.Value)

Bu kod yazmak yeterli olur bence, denemedim.

' Şehir isimlerini düzenle ve B6 hücresine yaz
Range("A2").Value = DuzenleEki(hücreB5.Value)

 

[veyselemre]

Bir modül içerisine aşağıdaki kodları ekleyin.

Function sehirleriEkle(sehirler)
    Dim s As Variant
    s = Split(sehirler, "-")
    sehirleriEkle = ayrilmaEkiEkle(Trim(s(0))) & " " & yonelmeEkiEkle(Trim(s(1)))
End Function
Function yonelmeEkiEkle$(metin$)
    metin = Trim(metin)
    Dim sonKar$, i%, ek$
    For i = 1 To Len(metin)
        sonKar = Mid(StrReverse(metin), i, 1)
        If InStr("aıoueiöü", sonKar) Then
            If i = 1 Then ek = "y"
            Exit For
        End If
    Next i
    yonelmeEkiEkle = metin & "'" & ek & IIf(InStr("aıou", sonKar), "a", "e")
End Function
Function ayrilmaEkiEkle$(metin$)
    Dim i%, sonKar$, ek$
    metin = Trim(metin)
    sonKar = Right(metin, 1)
    If InStr("fstkçşhp", sonKar) Then ek = "t" Else ek = "d"
    For i = 1 To Len(metin)
        sonKar = Mid(StrReverse(metin), i, 1)
        If InStr("aıoueiöü", sonKar) Then Exit For
    Next i
    ayrilmaEkiEkle = metin & "'" & ek & IIf(InStr("aıou", sonKar), "an", "en")
End Function
Function tamlayanEkiEkle$(metin$)
    metin = Trim(metin)
    Dim sonKar$, i%, ek$
    For i = 1 To Len(metin)
        sonKar = Mid(StrReverse(metin), i, 1)
        If InStr("aıoueiöü", sonKar) Then
            If i = 1 Then ek = "n"
            Exit For
        End If
    Next i
    Select Case sonKar
    Case "a", "ı": ek = ek & "ın"
    Case "e", "i": ek = ek & "in"
    Case "o", "u": ek = ek & "un"
    Case "ö", "ü": ek = ek & "ün"
    End Select
    tamlayanEkiEkle$ = metin & "'" & ek
End Function

B5 Hücresinde şehirler olması lazım.
A2 hücresine
="21.12.2023 tarihinde " & sehirleriEkle(B5) & " yaptığım yolculuk"
ekleyin.

 

[Golyaka07]

Merhaba, kendi fonksiyonunuzu kullanarak:

="21.12.2023 tarihinde " & DuzenleEki(B5) &" yaptığım yolculuk."

Ek tavsiye şu satırı:
s = Split(sehirler, " - ")
şu şekilde yazmak kullanıcı yazım hatasını gidermek için daha mantıklı.
s = Split(sehirler, "-")

Bu şekilde oldu - işaretinin sağındaki ve solundaki boşluk yüzünden hata almış olabilirim teşekkür ederim

 

[Golyaka07]

Bir modül içerisine aşağıdaki kodları ekleyin.

Function sehirleriEkle(sehirler)
    Dim s As Variant
    s = Split(sehirler, "-")
    sehirleriEkle = ayrilmaEkiEkle(Trim(s(0))) & " " & yonelmeEkiEkle(Trim(s(1)))
End Function
Function yonelmeEkiEkle$(metin$)
    metin = Trim(metin)
    Dim sonKar$, i%, ek$
    For i = 1 To Len(metin)
        sonKar = Mid(StrReverse(metin), i, 1)
        If InStr("aıoueiöü", sonKar) Then
            If i = 1 Then ek = "y"
            Exit For
        End If
    Next i
    yonelmeEkiEkle = metin & "'" & ek & IIf(InStr("aıou", sonKar), "a", "e")
End Function
Function ayrilmaEkiEkle$(metin$)
    Dim i%, sonKar$, ek$
    metin = Trim(metin)
    sonKar = Right(metin, 1)
    If InStr("fstkçşhp", sonKar) Then ek = "t" Else ek = "d"
    For i = 1 To Len(metin)
        sonKar = Mid(StrReverse(metin), i, 1)
        If InStr("aıoueiöü", sonKar) Then Exit For
    Next i
    ayrilmaEkiEkle = metin & "'" & ek & IIf(InStr("aıou", sonKar), "an", "en")
End Function
Function tamlayanEkiEkle$(metin$)
    metin = Trim(metin)
    Dim sonKar$, i%, ek$
    For i = 1 To Len(metin)
        sonKar = Mid(StrReverse(metin), i, 1)
        If InStr("aıoueiöü", sonKar) Then
            If i = 1 Then ek = "n"
            Exit For
        End If
    Next i
    Select Case sonKar
    Case "a", "ı": ek = ek & "ın"
    Case "e", "i": ek = ek & "in"
    Case "o", "u": ek = ek & "un"
    Case "ö", "ü": ek = ek & "ün"
    End Select
    tamlayanEkiEkle$ = metin & "'" & ek
End Function

B5 Hücresinde şehirler olması lazım.
A2 hücresine
="21.12.2023 tarihinde " & sehirleriEkle(B5) & " yaptığım yolculuk"
ekleyin.

Bu formül kusursuz olmuş ben formülün eksik kısımlarını tamamlamak istiyordum siz yapmışsınız tüm ekleri kusursuz ekliyor çok teşekkür ederim.