• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Düşeyara Ayraç KTF Hk.

M

mhrcvk

Katılım
18 Ekim 2012
Mesajlar
126
Excel Vers. ve Dili
2016 türkçe
Merhabalar,

Aşağıdaki KTF de nerede sorun olabilir ilgili formülü yazdığımda hata alıyorum. Kullanılan formül =DÜŞEYARA_AYRAÇ(G4;B:B;D : D;";")

Function DÜŞEYARA_AYRAÇ(Aranan_Deger As Variant, Bakilan_Aralik As Range, Getirilecek_Aralik As Range, ayrac As Variant) As String

Dim sonuc As String

Dim sonuc_Gecici As String

Dim satir As Long

Dim sutun As Long

Const bslAyrac = “|||”



sonuc = bslAyrac

For satir = 1 To Bakilan_Aralik.Rows.Count

For sutun = 1 To Bakilan_Aralik.Columns.Count

If Bakilan_Aralik.Cells(satir, sutun).Value = Aranan_Deger Then

sonuc_Gecici = Getirilecek_Aralik.Offset(satir – 1, sutun – 1).Cells(1, 1).Value

If InStr(1, sonuc, bslAyrac & sonuc_Gecici & bslAyrac) = 0 Then

sonuc = sonuc & sonuc_Gecici & bslAyrac

End If

End If

Next

Next

sonuc = Replace(sonuc, bslAyrac, ayrac)

If Left(sonuc, 1) = ayrac Then sonuc = Mid(sonuc, 2)

If Right(sonuc, 1) = ayrac Then sonuc = Left(sonuc, Len(sonuc) – 1)

If Len(sonuc) > 0 Then DÜŞEYARA_AYRAÇ = sonuc Else DÜŞEYARA_AYRAÇ = “BULUNAMADI”



End Function
 

Ekli dosyalar

Sorunuz için keşke bir örnek belge yükleseydiniz.
Aşağıdaki tüm kod satırlarındaki EKSİ işaretlerini,
Const bslAyrac = "|||"
Genişletmek için tıkla ...
kısmındaki çift tırnak işaretlerini silip yeniden yazarak bir deneyin isterseniz.
Ayrıca işlev adında Türkçe karakter kullanmamanızı öneriyorum.
DÜŞEYARA_AYRAÇ
Genişletmek için tıkla ...
 
Son düzenleme:
Ömer BARAN' Alıntı:
Sorunuz için keşke bir örnek belge yükleseydiniz.
Aşağıdaki tüm kod satırlarındaki EKSİ işaretlerini, kısmındaki çift tırnak işaretlerini silip yeniden yazarak bir deneyin isterseniz.
Ayrıca işlev adında Türkçe karakter kullanmamanızı öneriyorum.
Genişletmek için tıkla ...

Ömer Bey,
O değişiklik sorunu çözmedi belirttiğiniz üzere konuya ek ekledim yardımcı olursanız sevinirim.
 
Aşağıdaki KTF yi bir modüle ekleyin.

Kod: 
Function LookUpConcat(ByVal SearchString As String, SearchRange As Range, ReturnRange As Range, _
                      Optional Delimiter As String = " ", Optional MatchWhole As Boolean = True, _
                      Optional UniqueOnly As Boolean = False, Optional MatchCase As Boolean = False)
                  
  Dim X As Long, CellVal As String, ReturnVal As String, Result As String
 
  If (SearchRange.Rows.Count > 1 And SearchRange.Columns.Count > 1) Or _
     (ReturnRange.Rows.Count > 1 And ReturnRange.Columns.Count > 1) Then
    LookUpConcat = CVErr(xlErrRef)
  Else
    If Not MatchCase Then SearchString = UCase(SearchString)
    For X = 1 To SearchRange.Count
      If IsError(SearchRange(X)) Then GoTo Continue
      If MatchCase Then
        CellVal = SearchRange(X).Value
      Else
        CellVal = UCase(SearchRange(X).Value)
      End If
      ReturnVal = ReturnRange(X).Value
      If MatchWhole And CellVal = SearchString Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      ElseIf Not MatchWhole And CellVal Like "*" & SearchString & "*" Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      End If
Continue:
    Next
    
    LookUpConcat = Mid(Result, Len(Delimiter) + 1)
  End If
End Function

I2 hücresine

Kod: 
=LookUpConcat(G2;$A$2:$A$9;$B$2:$B$9;";";0)

yazıp aşağı doğru çekiniz.
 
Kodlarınızda, önceki cevabımda belirttiğim hususları düzeltince istenilen sonuçlar alınıyor.
İlgili kod satırlarını aşağıdakilerle değiştirin.
Kod: 
''...............
Const bslAyrac = "|||"
'...............
sonuc_Gecici = Getirilecek_Aralik.Offset(satir - 1, sutun - 1).Cells(1, 1).Value
'...............
If Right(sonuc, 1) = ayrac Then sonuc = Left(sonuc, Len(sonuc) - 1)
'...............
 
Ali' Alıntı:
Aşağıdaki KTF yi bir modüle ekleyin.

Kod: 
Function LookUpConcat(ByVal SearchString As String, SearchRange As Range, ReturnRange As Range, _
                      Optional Delimiter As String = " ", Optional MatchWhole As Boolean = True, _
                      Optional UniqueOnly As Boolean = False, Optional MatchCase As Boolean = False)
                 
  Dim X As Long, CellVal As String, ReturnVal As String, Result As String

  If (SearchRange.Rows.Count > 1 And SearchRange.Columns.Count > 1) Or _
     (ReturnRange.Rows.Count > 1 And ReturnRange.Columns.Count > 1) Then
    LookUpConcat = CVErr(xlErrRef)
  Else
    If Not MatchCase Then SearchString = UCase(SearchString)
    For X = 1 To SearchRange.Count
      If IsError(SearchRange(X)) Then GoTo Continue
      If MatchCase Then
        CellVal = SearchRange(X).Value
      Else
        CellVal = UCase(SearchRange(X).Value)
      End If
      ReturnVal = ReturnRange(X).Value
      If MatchWhole And CellVal = SearchString Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      ElseIf Not MatchWhole And CellVal Like "*" & SearchString & "*" Then
        If UniqueOnly And InStr(Result & Delimiter, Delimiter & ReturnVal & Delimiter) > 0 Then GoTo Continue
        Result = Result & Delimiter & ReturnVal
      End If
Continue:
    Next
   
    LookUpConcat = Mid(Result, Len(Delimiter) + 1)
  End If
End Function

I2 hücresine

Kod: 
=LookUpConcat(G2;$A$2:$A$9;$B$2:$B$9;";";0)

yazıp aşağı doğru çekiniz.
Genişletmek için tıkla ...


İki Modülüde ekledim fakat bende çalışmıyor KTF'leri biryerde etkinleştirmem mi gerekiyor anlamadım ?
 

Ekli dosyalar

Sizin modülünüzüde bir üst mesajdaki konuya ekledim fakat çalışmıyor ktflerin bir yerde etkinleştirilmesimi gerekiyor acaba ?
 
Sorunu Çözdüm Ömer bey ve Ali bey ikinize de ilginiz için çok teşekkür ederim.
 
Çok teşekkür ederim dediğiniz gibi yaptım oldu.
Fakat "*" yıldızı kullandığımda yani hücrenin içerisinde belli bir kelime aradığımda sonuçları getirmiyor. acaba aşağıdaki koda joker karekterlerle arama yapabileceği bir ilave kod eklenebilir mi?

If Bakilan_Aralik.Cells(satir, sutun).Value = "*" & Aranan_Deger & "*" Then bu olmadı
 
Arkadaşlar benim için gerçekten önemli. beni büyük bir iş yükünden kurtaracak. emeği geçenlere şimdiden çok teşekkür ederim.
"*" yıldızı kullandığımda yani hücrenin içerisinde belli bir kelime aradığımda sonuçları getirmiyor. acaba bu koda joker karekterlerle arama yapabileceği bir ilave kod eklenebilir mi?
If Bakilan_Aralik.Cells(satir, sutun).Value = "*" & Aranan_Deger & "*" Then bu olmadı yada ben yapamadım.

Function DÜŞEYARA_AYRAC(Aranan_Deger As Variant, Bakilan_Aralik As Range, Getirilecek_Aralik As Range, ayrac As Variant) As String

Dim sonuc As String

Dim sonuc_Gecici As String

Dim satir As Long

Dim sutun As Long

Const bslAyrac = "|||"



sonuc = bslAyrac

For satir = 1 To Bakilan_Aralik.Rows.Count

For sutun = 1 To Bakilan_Aralik.Columns.Count

If Bakilan_Aralik.Cells(satir, sutun).Value = Aranan_Deger Then

sonuc_Gecici = Getirilecek_Aralik.Offset(satir - 1, sutun - 1).Cells(1, 1).Value

If InStr(1, sonuc, bslAyrac & sonuc_Gecici & bslAyrac) = 0 Then

sonuc = sonuc & sonuc_Gecici & bslAyrac

End If

End If

Next

Next

sonuc = Replace(sonuc, bslAyrac, ayrac)

If Left(sonuc, 1) = ayrac Then sonuc = Mid(sonuc, 2)

If Right(sonuc, 1) = ayrac Then sonuc = Left(sonuc, Len(sonuc) - 1)

If Len(sonuc) > 0 Then DÜŞEYARA_AYRAC = sonuc Else DÜŞEYARA_AYRAC = “BULUNAMADI”



End Function
 
Eşittir sembolünü kullandığınız anda eşitlik sorguladığınız anlamına gelecektir. Bunun yerine içerir mantığı ile LIKE işlecini kullanmanız daha uygun olacaktır.

If Bakilan_Aralik.Cells(satir, sutun).Value Like "*" & Aranan_Deger & "*" Then
 
Korhan Hocam ben size nasıl teşekkür edeyim bilemedim Allah razı olsun hocam süpersiniz
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst