ExcelVBA.Net sitesine katkıda bulunabilirsiniz

[Tamermaster]

Bir hücre başvurusunda birden fazla kelimeyi değiştiren KTF

Kod: Tümünü seç

Function Yenile(Metin As Variant, ByVal Eski As Variant, ByVal Yeni As Variant, _
Optional ByVal Eski1 As Variant = "", Optional ByVal Yeni1 As Variant = "", _
Optional ByVal Eski2 As Variant = "", Optional ByVal Yeni2 As Variant = "", _
Optional ByVal Eski3 As Variant = "", Optional ByVal Yeni3 As Variant = "", _
Optional ByVal Eski4 As Variant = "", Optional ByVal Yeni4 As Variant = "")

Kod1 = Replace(Metin, Eski, Yeni)
Kod2 = Replace(Kod1, Eski1, Yeni1)
Kod3 = Replace(Kod2, Eski2, Yeni2)
Kod4 = Replace(Kod3, Eski3, Yeni3)
Kod5 = Replace(Kod4, Eski4, Yeni4)
Yenile = Kod5

End Function


KDV li fiyattan KDV siz fiyatı bulan KTF

Kod: Tümünü seç

Function FiyatBul(Tutar As Double, Optional ByVal Yüzde As Currency)

If Yüzde = Empty Then
FiyatBul = Tutar / 1.18
Else
    If Yüzde < 1 Then
    Oran = Yüzde
    Else
    Oran = (Yüzde / 100)
    End If
    FiyatBul = Tutar / (1 + Oran)
End If
End Function


KDV li fiyattan KDV yi bulan KTF

Kod: Tümünü seç

Function KDV(Fiyat As Double, Optional ByVal Yüzde As Currency)

If Yüzde = Empty Then
KDV = Fiyat * 1.18
Else
    If Yüzde < 1 Then
    Oran = Yüzde
    Else
    Oran = (Yüzde / 100)
    End If
    KDV = Fiyat * (1 + Oran)
End If

End Function


Direnç Watt Ohm değeri bulan KTF

Kod: Tümünü seç

Function Direnç(Volt, Akım As Double)
Wat = Left((Volt * Akım), 6)
Dren = Left((Volt / Akım), 6)
If Dren < 1000 Then
Direnç = Dren & " Ohm " & Wat & " W"
Else
Direnç = Dren / 1000 & " K " & Wat & " W"
End If
End Function


[Tamermaster]

Aranan değerin satır numarasını bulan KTF
Aranan değer birden fazla ise kaçıncı değerin satır numarasını istiyorsanız bulan KTF

Kod: Tümünü seç

Function AraStrNoYaz(ByVal Aranan As String, ByVal AramaAlani As Range, ByVal KacSutun As Integer, Optional ByVal Kacinci As Integer) As String
On Error Resume Next
Dim Metin As String, Veri As Variant, i As Long

If Aranan = "" Then Exit Function
Veri = AramaAlani.Value2
For i = 1 To UBound(Veri)
    If CStr(Veri(i, KacSutun)) = Aranan Then
     Metin = Metin & i & ";"
    End If
Next i
If Kacinci = "" Then Kacinci = 1
Dizi = Split(Metin, ";")
    AraStrNoYaz = Dizi(Kacinci - 1)
End Function


[Miraç CAN]

Burada bir sıkıntı var. Fonksiyon tanımı mı yanlış yoksa?
KDV'li fiyat bulma olabilir ancak.

KDV li fiyattan KDV yi bulan KTF

Kod: Tümünü seç

Function KDV(Fiyat As Double, Optional ByVal Yüzde As Currency)

If Yüzde = Empty Then
KDV = Fiyat * 1.18
Else
    If Yüzde < 1 Then
    Oran = Yüzde
    Else
    Oran = (Yüzde / 100)
    End If
    KDV = Fiyat * (1 + Oran)
End If

End Function


KDV li fiyattan KDV yi bulan KTF;

Kod: Tümünü seç

Function KDV(Fiyat As Double, Optional ByVal Yüzde As Currency)
If Yüzde = Empty Then
KDV = Fiyat - (Fiyat / 1.18)
Else
    If Yüzde < 1 Then
    Oran = Yüzde
    Else
    Oran = (Yüzde / 100)
    End If
    KDV = Fiyat - (Fiyat / (1 + Oran))
End If

End Function

[Miraç CAN]

Aranan değerin satır numarasını bulan KTF
Aranan değer birden fazla ise kaçıncı değerin satır numarasını istiyorsanız bulan KTF

Kod: Tümünü seç

Function AraStrNoYaz(ByVal Aranan As String, ByVal AramaAlani As Range, ByVal KacSutun As Integer, Optional ByVal Kacinci As Integer) As String
On Error Resume Next
Dim Metin As String, Veri As Variant, i As Long

If Aranan = "" Then Exit Function
Veri = AramaAlani.Value2
For i = 1 To UBound(Veri)
    If CStr(Veri(i, KacSutun)) = Aranan Then
     Metin = Metin & i & ";"
    End If
Next i
If Kacinci = "" Then Kacinci = 1
Dizi = Split(Metin, ";")
    AraStrNoYaz = Dizi(Kacinci - 1)
End Function


Gayet kullanışlı KTF'ler olmuş Tamer Bey, ellerinize sağlık, teşekkürler paylaşımınız için.

[Tamermaster]

Haklısın KDV'li fiyatı bulan KTF olacak teşekkür ederim
Eksiğimizi tamamlayalım o zaman.
Fiyattan KDV bulan KTF

Kod: Tümünü seç

Function KDVBul(Fiyat As Double, Optional ByVal Yüzde As Currency)
skz = Int(Fiyat - (Fiyat / 1.08))
oskz = Int(Fiyat - (Fiyat / 1.18))

If Yüzde = Empty Then
    If Fiyat = (skz + (Fiyat / 1.08)) Then
    KDVBul = Fiyat - (Fiyat / 1.08)
    Else
    KDVBul = Fiyat - (Fiyat / 1.18)
    End If
Else
    If Yüzde < 1 Then
    KDVBul = Fiyat - (Fiyat / (1 + Yüzde))
    Else
    KDVBul = Fiyat - (Fiyat / ((100 + Yüzde) / 100))
    End If
End If

End Function


[Tamermaster]

FazlaYenile
Yerinekoy Fonksiyonu bildiğiniz gibi kaç tane varsa tamamını yeniler. Bu Fonksiyon bulunan değer Birden fazla İse ve hepsini değiştirmek istemiyorsanız, sadece değiştirmek istediğinizi değiştirecektir.
Örnek aynı cümle(Hücre) içinde 4 tane aynı kelime var siz sadece 3.yü değiştirmek istiyorsanız KacYenile ile bunu yapabiliyorsunuz.
Güle güle kullanın.
Not : bir kelime(bölüm) içinde harf değiştirmek isterseniz o kelimede de o harften birden fazla var ise o kelime içindeki o harfleri değiştirir.

Kod: Tümünü seç

Function KacYenile(ByVal Hücre As String, Bul As String, Değiştir As String, Optional Kaçıncı As Byte)
Dim a As Byte, b As Byte, say As Byte, i As Byte, s As Byte
Dim Bak As String, Bak1 As String, Bak2 As String, Bak3 As String, Bak4 As String, Bak5 As String, Bak6 As String
a = 0
b = 0
Dim Klm
Klm = Split(Hücre, " ")
For say = LBound(Klm) To UBound(Klm)
Veri = Klm(say)
b = b + 1
If InStr(Veri, Bul) > 0 Then
a = a + 1
If a = Kaçıncı Then
  For i = LBound(Klm) To b - 1
   Bak = Bak & " " & Klm(i)
  t = b
  Next i
End If
End If
Next say
Bak2 = Replace(Klm(t - 1), Bul, Değiştir)
Bak3 = Bak & " " & Bak2
For s = t To UBound(Klm)
Bak4 = Bak4 & " " & Klm(s)
Next s
Bak5 = Bak3 & Bak4
Bak6 = Right(Bak5, Len(Bak5) - 1)
KacYenile = Bak6
End Function


Lütfen KTF leri denedikten sonra eksik gördüklerinizi paylaşın.

[Tamermaster]

Dirençler üzerinden geçen akım ve voltajı veren KTF

Kod: Tümünü seç

Function DirenceDüşen(BeslemeVoltajı As Double, Direnç1 As Double, Optional Direnç2 As Double, Optional Direnç3 As Double, Optional Direnç4 As Double, Optional Direnç5 As Double, _
Optional Direnç6 As Double, Optional Direnç7 As Double, Optional Direnç8 As Double, Optional Direnç9 As Double, Optional Direnç10 As Double, Optional Direnç11 As Double, _
Optional Direnç12 As Double, Optional Direnç13 As Double, Optional Direnç14 As Double, Optional Direnç15 As Double, Optional Direnç16 As Double, Optional Direnç17 As Double)
Değişken = Array(Direnç1, Direnç2, Direnç3, Direnç4, Direnç5, Direnç6, Direnç7, Direnç8, Direnç9, Direnç10, Direnç11, Direnç12, Direnç13, Direnç14, Direnç15, Direnç16, Direnç17)
Dim i As Byte, TDirenç As Double, Dolu As Byte, Ampe As Double

For i = LBound(Değişken) To UBound(Değişken)
If Değişken(i) <> 0 Then
TDirenç = Değişken(i) + TDirenç
Dolu = i
End If
Next i
amp = BeslemeVoltajı / TDirenç
For v = LBound(Değişken) To UBound(Değişken)
If Değişken(v) <> 0 Then
Rv = Rv & "Rv" & v + 1 & "= " & (Değişken(v) * amp) & "Volt, "
End If
Next v
rvs = Left(Rv, Len(Rv) - 2)
DirenceDüşen = amp & " Amper ," & rvs
End Function


[Tamermaster]

Yazarken kontrol eden Eğer fonksiyonu KTF.

Kod: Tümünü seç

Function eeyer(x As Variant, y As Byte, A As Variant, Optional ByVal Ae, Optional ByVal Ab, Optional ByVal Ak, Optional ByVal Aeb, Optional ByVal Aek As Variant)

If y = 1 Then
If x < A Then
  If Ab <> "" Then
  eeyer = Ab
  Else
  eeyer = "A X ten Büyük"
  End If
ElseIf x > A Then
  If Ak <> "" Then
   eeyer = Ak
  Else
  eeyer = "A X ten Küçük"
  End If
Else
  If Ae <> "" Then
  eeyer = Ae
  Else
  eeyer = "A X e Eşit"
  End If
End If
ElseIf y = 2 Then
If x >= A Then
  If Aek <> "" Then
  eeyer = Aek
  Else
  eeyer = "A X e Eşit Yada A X ten Küçük"
  End If
Else
  If Aeb <> "" Then
  eeyer = Aeb
  Else
  eeyer = " A X e Eşit Yada A X ten Büyük"
  End If
End If

End If

End Function


[Tamermaster]

X ve A değerleri kontrol edilecek değerler.
Y Kontrol sonucu her iki ihtimali içeriyorsa 2, tek karşılaştırma sonucu için 1 yazılmalı
Ae ye X A ya eşitse girilecek değer.
Ab ye A X ten büyükse girilecek değer.
Ak ye A X ten küçükse girilecek değer.
Aeb ye A X ten büyük yada X e eşitse gelecek değer.
Aek ye A X ten küçük yada X e eşitse gelecek değer girilir.
Aeb ve Aek de sonuç istiyorsanız Y ye 2 yazın, tek sonuç için Y ye 1 yazın.
Sonuç bölümleri (Ae,Ab,Ak,Aeb,Akb) boş bırakılırsa değerlendirme sonucunu yazar.
(Önceki KTF sonuç değerleri yerine değişken ile yazar.)

Yazarken kontrol eden Eğer fonksiyonu KTF.

Kod: Tümünü seç

Function eeyer(X As Variant, Y As Byte, A As Variant, Optional ByVal Ae, Optional ByVal Ab, Optional ByVal Ak, Optional ByVal Aeb, Optional ByVal Aek As Variant)

If Y = 1 Then
If X < A Then
  If Ab <> "" Then
  eeyer = Ab
  Else
  eeyer = A & " " & X & " ten Büyük"
  End If
ElseIf X > A Then
  If Ak <> "" Then
   eeyer = Ak
  Else
  eeyer = A & " " & X & " ten Küçük"
  End If
Else
  If Ae <> "" Then
  eeyer = Ae
  Else
  eeyer = A & " " & X & "e Eşit"
  End If
End If
ElseIf Y = 2 Then
If X >= A Then
  If Aek <> "" Then
  eeyer = Aek
  Else
  eeyer = A & " " & X & " e Eşit Yada " & A & " " & X & " ten Küçük"
  End If
Else
  If Aeb <> "" Then
  eeyer = Aeb
  Else
  eeyer = A & " " & X & " e Eşit Yada " & A & " " & X & " ten Büyük"
  End If
End If

End If

End Function


[Tamermaster]

Üçgen ile ilgili KTF'ler
Eşkenar üçgende alan bulma fonksiyonu

Kod: Tümünü seç

Function EşKenarAlan(Kenar_Uzunluğu As Double)
kök = (3 ^ (1 / 2)) / 4
EşKenarAlan = Kenar_Uzunluğu ^ 2 * kök
End Function


[Tamermaster]

Dik üçgende Hipotenüs uzunluğu bulma fonksiyonu

Kod: Tümünü seç

Function Hipotenüs(Kenar1, Kenar2 As Double)
Hipotenüs = (Kenar1 ^ 2 + Kenar2 ^ 2) ^ (1 / 2)

End Function


[Tamermaster]

Uzunkenarı(Hipotenüsü) bilinen dik üçgende kenar uzunluğu bulma fonksiyonu

Function DikÜçgenKenar(Hipotenüs, Kenar As Double)
DikÜçgenKenar = (Hipotenüs ^ 2 - Kenar ^ 2) ^ (1 / 2)
End Function

[Tamermaster]

Kenar uzunlukları bilinen üçgende alan bulma fonksiyonu

Kod: Tümünü seç

Function ÜçgenAlan(a, b, c As Double)
s = (a + b + c) / 2
ÜçgenAlan = (s * (s - a) * (s - b) * (s - c)) ^ (1 / 2)
End Function


[Tamermaster]

Ardışık sayıların toplanması için fonksiyon.

Kod: Tümünü seç

Function ArdışıkTopla(Sayı As Integer, Optional ByVal Başlangıç As Integer)

If Başlangıç > 0 Then
    If Sayı Mod 2 = 0 Then
    Birden = (Sayı + 1) * (Sayı / 2)
    BirdenBaş = (Başlangıç + 1) * (Başlangıç / 2)
    ArdışıkTopla = Birden - BirdenBaş + Başlangıç
    Else
    Birden = ((Sayı + 1) / 2) * Sayı
    BirdenBaş = ((Başlangıç + 1) / 2) * Başlangıç
    ArdışıkTopla = Birden - BirdenBaş + Başlangıç
    End If
Else
    If Sayı Mod 2 = 0 Then
    ArdışıkTopla = (Sayı + 1) * (Sayı / 2)
    Else
    ArdışıkTopla = ((Sayı + 1) / 2) * Sayı
    End If
End If


[Arkadasca]

Dik üçgende Hipotenüs uzunluğu bulma fonksiyonu

Kod: Tümünü seç

Function Hipotenüs(Kenar1, Kenar2 As Double)
Hipotenüs = (Kenar1 ^ 2 + Kenar2 ^ 2) ^ (1 / 2)

End Function


Paylaşımlarınız için teşekkür ederim. Emeğinize sağlık...

Yukarıdaki fonksiyonun kullanımı ile ilgili bir örnek paylaşabilir misiniz?

[Miraç CAN]

Fonksiyonu bir modüle ekleyip herhangi bir makroya UzunKenar = Hipotenüs(3, 4)
Ya da hücreye =Hipotenüs(3;4)

[Arkadasca]

Fonksiyonu bir modüle ekleyip herhangi bir makroya UzunKenar = Hipotenüs(3, 4)
Ya da hücreye =Hipotenüs(3;4)

Miraç Bey,
İlginiz için teşekkür ederim.
VBA tarafındaki uygulamayı biliyorum.
Örnek kullanımı sormuştum. Bir üçgenin kenarlarını nasıl hesaplıyor?
Formül üzerinden mi gidiliyor?
Örnek gönderir misiniz?

[Miraç CAN]

Adsız.png

[Tamermaster]

Biran fazla sonuç veren aramalarda kullanabileceğiniz bir düşey arama KTF si

Kod: Tümünü seç

Function AraAyir(ByVal aranan As String, ByVal AramaAlani As Range, ByVal Kacinci_Sutun As Integer, Optional ByVal Kacinci_Kelime As Integer = 1) As String
Dim Metin As String, Veri As Variant, i As Long
If aranan = "" Then Exit Function
Veri = AramaAlani.Value2
For i = 1 To UBound(Veri)
    If CStr(Veri(i, 1)) = aranan Then
   
        Metin = Metin & Veri(i, Kacinci_Sutun) & "/"
    End If
Next i
    Sonuc = Mid(Metin, 1, Len(Metin) - 1)
   
        If InStr(1, Sonuc, "/", vbTextCompare) > 0 Then
        Dim Dizi
        Dim say As Integer
        Dizi = Split(Sonuc, "/")
        say = UBound(Dizi) + 1
        If Kacinci_Kelime > say Then AraAyir = 0
        If Kacinci_Kelime < 1 Then Kacinci_Kelime = 1
        AraAyir = Dizi(Kacinci_Kelime - 1)
    Else
        AraAyir = ""
  End If
End Function


[Tamermaster]

Seçim değişkenine yazacağınız değere göre farklı kullanabilirsiniz. Son dolu hücreyi sütunu 1. satırdan seçersek verir.
Son dolu hücreyi bulur(1)
Boş hücrelerin sayısını verir( Boş bıraksanız da 0 yasanızda fark etmez )
Dolu hücrelerin sayısını verir(2)
Rakam bulunan hücrelerin sayısını verir(3)
Metin bulunan hücrelerin sayısını verir(4)

Kod: Tümünü seç

Function SonBul(ByVal AramaSutunu As Range, Optional ByVal Seçim As Double) As String
On Error Resume Next
Dim Veri As Variant
Dim i As Long
Dim b As Long
Dim s As Long
Dim m As Long
Dim bos As Long
Dim soon As Long

Veri = AramaSutunu.Value2
For i = 1 To UBound(Veri)
If Veri(i, 1) <> "" Then
If Veri(i, 1) <> "" Then
b = b + 1
If IsNumeric(Veri(i, 1)) Then
s = s + 1
End If
If Not IsNumeric(Veri(i, 1)) Then
m = m + 1
End If
End If
soon = i
Else
bos = bos + 1
End If
Next i
If Seçim <> "" Then
If Seçim = 1 Then
Sonuç = soon
ElseIf Seçim = 2 Then
Sonuç = b
ElseIf Seçim = 3 Then
Sonuç = s
ElseIf Seçim = 4 Then
Sonuç = m
ElseIf Seçim = 0 Then
Sonuç = bos
End If
End If

    SonBul = Sonuç
End Function


[url][url=https://hizliresim.com/E7QbLG][/url][/url]