Düşeyara Ayraç KTF Hk.

[mhrcvk]

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

 

[Ömer BARAN]

Sorunuz için keşke bir örnek belge yükleseydiniz.
Aşağıdaki tüm kod satırlarındaki EKSİ işaretlerini,

Const bslAyrac = "|||"

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Ç

 

[mhrcvk]

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.

Ömer Bey,
O değişiklik sorunu çözmedi belirttiğiniz üzere konuya ek ekledim yardımcı olursanız sevinirim.

 

[Ali]

Aşağıdaki KTF yi bir modüle ekleyin.

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

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

yazıp aşağı doğru çekiniz.

 

[Ömer BARAN]

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.

''...............
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)
'...............

 

[mhrcvk]

Aşağıdaki KTF yi bir modüle ekleyin.

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

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

yazıp aşağı doğru çekiniz.

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

 

[mhrcvk]

Sizin modülünüzüde bir üst mesajdaki konuya ekledim fakat çalışmıyor ktflerin bir yerde etkinleştirilmesimi gerekiyor acaba ?

 

[mhrcvk]

Sorunu Çözdüm Ömer bey ve Ali bey ikinize de ilginiz için çok teşekkür ederim.

 

[ramazan kuyumcu]

Nasıl çözdünüz sorunu hocam aynısı bende de oldu

 

[ramazan kuyumcu]

Ç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ı

 

[ramazan kuyumcu]

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

 

[Korhan Ayhan]

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

 

[ramazan kuyumcu]

Korhan Hocam ben size nasıl teşekkür edeyim bilemedim Allah razı olsun hocam süpersiniz