• DİKKAT

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

Bul Butonu ile ürün koduna göre verileri getirme

Merhaba.

Aşağıdaki kodu, sayfaya eklediğiniz düğmeyle ilişkilendirin.
Fiyat sayfası B3 hücresinin biçimini METİN olarak ayarlayın.
.
Kod: 
[B][COLOR="blue"]Sub ARAMA()[/COLOR][/B]
Set fl = Sheets("Fiyat Liste"): Set f = Sheets("Fiyat")
If f.Cells(Rows.Count, 2).End(3).Row > 5 Then _
    f.Range("A6:F" & f.Cells(Rows.Count, 2).End(3).Row).ClearContents
If f.[B3] = "" Then
    MsgBox "Aranacak veri yazılmadan arama sonuç vermez!", vbCritical, "..:: Ömer BARAN ::.."
    Exit Sub
ElseIf WorksheetFunction.CountIf(fl.[F:F], f.[B3]) = 0 Then
    MsgBox "Aranan veri bulunamadı!", vbCritical, "..:: Ömer BARAN ::.."
    Exit Sub
Else
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    On Error Resume Next
    If fl.AutoFilterMode = True Then fl.AutoFilterMode = False
    fl.ShowAllData
    fl.Range("A1:F" & Rows.Count).AutoFilter Field:=6, Criteria1:=f.[B3]
    If fl.Cells(Rows.Count, 1).End(3).Row > 1 Then
        fl.Range("A2:E" & fl.Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Copy f.[B6]
        f.Range("A6:A" & f.Cells(Rows.Count, 2).End(3).Row) = f.[B3]
    End If
    fl.Range("A1:F" & Rows.Count).AutoFilter Field:=6
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
    MsgBox "Arama sonuçları listelendi.", vbInformation, "..:: Ömer BARAN ::.."
    f.[B3].Select
End If[B][COLOR="Blue"]End Sub[/COLOR][/B]
 
Ömer BARAN' Alıntı:
Merhaba.

Aşağıdaki kodu, sayfaya eklediğiniz düğmeyle ilişkilendirin.
Fiyat sayfası B3 hücresinin biçimini METİN olarak ayarlayın.
.
Kod: 
[B][COLOR="blue"]Sub ARAMA()[/COLOR][/B]
Set fl = Sheets("Fiyat Liste"): Set f = Sheets("Fiyat")
If f.Cells(Rows.Count, 2).End(3).Row > 5 Then _
    f.Range("A6:F" & f.Cells(Rows.Count, 2).End(3).Row).ClearContents
If f.[B3] = "" Then Exit Sub
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
On Error Resume Next
If fl.AutoFilterMode = True Then fl.AutoFilterMode = False
fl.ShowAllData
If WorksheetFunction.CountIf(fl.[F:F], f.[B3]) = 0 Then GoTo 10
fl.Range("A1:F" & Rows.Count).AutoFilter Field:=6, Criteria1:=f.[B3]
If fl.Cells(Rows.Count, 1).End(3).Row > 1 Then
fl.Range("A2:E" & fl.Cells(Rows.Count, 1).End(3).Row).SpecialCells(xlCellTypeVisible).Copy f.[B6]
f.Range("A6:A" & f.Cells(Rows.Count, 2).End(3).Row) = f.[B3]
End If
fl.Range("A1:F" & Rows.Count).AutoFilter Field:=6
10: Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
[B][COLOR="Blue"]End Sub[/COLOR][/B]
Genişletmek için tıkla ...


Sayın Ömer BARAN Bey,

Öncelikle çok teşekkür ederim. Söylemiş olduğunuz gibi bütün adımları izledim ancak hiç bir şekilde işlem yapmadı.

http://www.dosya.tc/server13/2krsoj/Adsiz.jpg.html


http://www.dosya.tc/server13/m387o4/2018_Yiyecek-Icecek_Fiyat_Urun_Gruplari.rar.html
 
Merhaba,

Özür dileyerek düzeltiyorum. Listemde olmayan kodları girmişim devamlı herhangi bir veri gelmeyince çalışmadığını düşündüm.

Tekrardan çok teşekkür ederim.

Fiyat kısmının kalın ve kırmızı renkte çıkmasını istiyorum. Normal excelde yapıyorum ama farklı arama yaptığım zaman gidiyor. :-)
 
Son olarak sevgili üstadlarım,

Araştırma yaptım ama pek bulamadım gibi bir şey oldu. Forumda belki vardır ama yanlış arama da yapmış olabilirim. Aradığım stok kodu olmadığı zaman listede "Stok Kodu Bulunamamıştır." diye uyarı verirse.
 
Önceki cevabımı güncelledim.
Ayrıca işlemin uygulandığı belgeye fareyle buraya tıklayarak erişebilirsiniz.
Ayrıca belgede B3 hücresine VERİ DOĞRULAMA => LİSTE özelliği eklendi.
.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst