otomatik arama

[bedirster]

Merhaba,

ekte yer alan örnekte
servis takip sayfasında b1:b500 sütunları arasında cari isimlerimi genel sayfasındaki k1:k500 sütunundaki hücrelerden almak istiyorum.
düzenlediğim bir kod var ancak çalıştıramadım.

kodun mantığı b1:b500 aralığında her hangi bir hücreye k1:k500 de yer alan bir ismi yazarken filtre yaparak uygun cariyi b hücresine getirsin.
ilgili koddaki hatayı düzeltip çalışmasına yardımcı olabilir misiniz

 

[DoğanD]

Merhaba,

İki kısımda düzeltme yaptım, yanlarına belirttim. Kontrol edebilir misiniz?

Sub AramaYap()
    Dim hedefSayfa As Worksheet
    Dim veriSayfa As Worksheet
    Dim hedefHucresi As Range
    Dim veriHucresi As Range
    
    ' Aramayı yapmak istediğiniz sayfaları belirleyin (örnekte "Servis Takip Sayfası" ve "Genel Çalışma Sayfası")
    Set hedefSayfa = Sheets("Servis Takip")
    Set veriSayfa = Sheets("Genel")
    
    ' Hedef hücreleri dönerek, her bir hücredeki değeri arayın
    For Each hedefHucresi In hedefSayfa.Range("B2:B500") '-B1:B500 idi B2'den başlattım
        ' Veri sayfasındaki K sütununda arama yapın
        For Each veriHucresi In veriSayfa.Range("K1:K5")
            If InStr(1, veriHucresi.Value, hedefHucresi.Value, vbTextCompare) > 0 Then
                ' Eşleşme bulunduysa B sütununa ekleme yapın
                If IsEmpty(hedefHucresi.Offset(0, 1).Value) Then
                    hedefHucresi.Offset(0, 1).Value = veriHucresi.Offset(0, 1).Value
                Else
                    Dim eskiDeger As String
                    eskiDeger = CStr(hedefHucresi.Offset(0, 0).Value) '-Hedef Offset bir yanı gösteriyordu 0-0 yaptım'
                    Dim yeniDeger As String
                    yeniDeger = Join(Array(eskiDeger, CStr(veriHucresi.Value)), ", ")
                    hedefHucresi.Offset(0, 0).Value = yeniDeger '-Hedef Offset bir yanı gösteriyordu 0-0 yaptım'
                End If
            End If
        Next veriHucresi ' Veri hücresi döngüsünü sonlandır
    Next hedefHucresi ' Hedef hücresi döngüsünü sonlandır
End Sub

 

[bedirster]

Doğan Bey Merhaba,

Sanırım ben yine bir yerde hata yapıyorum. maalesef yine olmuyor. doya üzerinden yapıp yükleme şansınız var mı?

teşekkürler.
,