Makro ile sayfalarda düşey arama

[POLARIS]

İyi akşamlar,
Forumu epey aradıktan sonra Sayın yurttaş'ın bir çözümünü ekli dosyaya uyarladım.
Ama her nedense çalıştıramadım.Makro ayarlarım normal.Fakat benim makro bilgim çok zayıf.Bu konuda yardımcı olabilirmisiniz?

Teşekkür eder hepinize iyi çalışmalar dilerim.

 

[Korhan Ayhan]

Merhaba,

Aranan alanı yanlış sütundan başlatmışşsınız.

=DUSEYARASAYFALAR(B15;$[COLOR=red]C[/COLOR]$1:$G$5000;2;YANLIŞ)

 

[POLARIS]

Makro ile duseyara sayfalar

İyi akşamlar,
Korhan hocam çok teşekkür ederim.
Konuya fazla girince dağılmışım.

Peki hocam yazan kişiye kolaylık açısından ele alırsak,Nasıl bir kod yazmamız gerekecek,yardımcı olabilirmisiniz.

a-Kodu yazarsam B sütünuna ürün adını,Ürün adını yazarsam A sütununa kodunu yazacak.Bilgileri "KLASİK" ve "LED" sayfalarından alacak.

 

[Korhan Ayhan]

Aşağıdaki kodu DENEME isimli sayfanızın kod bölümüne uygulayıp deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Sayfa As Worksheet, Bul As Range
    
    On Error GoTo Son
    
    If Intersect(Target, Range("A15:B" & Rows.Count)) Is Nothing Then Exit Sub
    
    Application.EnableEvents = False
    
    If Target.Column = 1 Then
        Target.Next = ""
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> ActiveSheet.Name Then
                Set Bul = Sayfa.Range("B:B").Find(Target, , , xlWhole)
                If Not Bul Is Nothing Then
                    Target.Next = Bul.Offset(0, 1)
                    Exit For
                End If
            End If
        Next
    
    ElseIf Target.Column = 2 Then
        Target.Previous = ""
        For Each Sayfa In ThisWorkbook.Worksheets
            If Sayfa.Name <> ActiveSheet.Name Then
                Set Bul = Sayfa.Range("C:C").Find(Target, , , xlWhole)
                If Not Bul Is Nothing Then
                    Target.Previous = Bul.Offset(0, -1)
                    Exit For
                End If
            End If
        Next
    End If
    
Son: Application.EnableEvents = True
End Sub

 

[POLARIS]

Hocam bir harikasınız...
Tekrar teşekkür eder iyi geleler dilerim.
Esenkalınız....