Search Box (Arama Kutusundan Veri Çağırma)

[Kavinsky]

Değerli hocalarım merhaba,
Ben açılır liste yaptım ve yaklaşık 1000 adet ürün arasından istediğim ürünü seçip adet yazıp düşüm yapıyorum.
Derdim şu ki ;

Açılır listedeki parçaları seçerken sırası harf sırasına göre olmadığı için tek tek bulmaya çalışıyorum. Ben text.box ekleyerek bunu arama kutusuna çevirmek istiyorum.
Örnek olarak akü yazdığımda akü adı altında olan ürünler çıksın ve istediğimi seçeyim. Seçtiğim veriyi de "ÇIKIŞ" sayfasındaki "A2" sütununa yapıştırsın ben de adet yazıp düşümünü yapayım. Arama kutusu ise verileri "LİSTE" isimli sayfadan "A3:A5000" aralığından alsın.
Bu hususta işin içinden çıkamadım. Şimdiden çok teşekkür ederim

 

[yanginci34]

Örnek olarak dosyanızı burası gibi dosya yükleme formlarına yükleyip link paylaşırsanız daha kolay yardımcı olacaklardır.

 

[Kavinsky]

İndir SİSTEM

Dosyayı indir SİSTEM

dosya.co

Tabii ki , dosya ektedir.

 

[Korhan Ayhan]

Linki inceleyiniz.

https://www.excel.web.tr/threads/huecrede-otomatik-tamamlama.112308/

 

[Kavinsky]

Sayın hocam Altın üyelik olmadığı için ekleri indiremedim. Bu konuyu görmüştüm yoksa.

 

[Korhan Ayhan]

Paylaştığım linkte ilk mesajımda aslında harici link var. Ama bildiğiniz üzere bu tarz linkler bir süre sonra aktifliğini yitiriyor. Bu sebeple dosyaların forumun arşivinde olmasında fayda var.

Ben harici linki güncelledim. Şimdi indirip kendi dosyanıza uyarlamasını yapabilirsiniz.

 

[Kavinsky]

Hocam uyarlama yaptım çok teşekkür ederim. Sadece açıklama kısmı yani B sütunu arama yaptığımda gözükmüyor. Bunu çözemedim, bir yer de bir hata yaptım ama nerede

Private Sub TextBox1_Change()
    Dim X As Long, Say As Long
    Dim Aranan_LİSTE As String
    Dim Sorgulanan_LİSTE As String
    
    If TextBox1 <> "" Then
        Aranan_LİSTE = Evaluate("=UPPER(""" & TextBox1.Text & """)")
        
        ReDim Data(1 To 1, 1 To 2)
        
        For X = 1 To S1.Cells(Rows.Count, 1).End(3).Row
            Sorgulanan_LİSTE = Evaluate("=UPPER(""" & S1.Cells(X, 1).Text & """)")
            
            If InStr(1, Sorgulanan_LİSTE, Aranan_LİSTE, vbTextCompare) > 0 Then
                Say = Say + 1
                ReDim Preserve Data(1 To 1, 1 To Say)
                Data(1, Say) = S1.Cells(X, 1)
                Data(1, Say) = S1.Cells(X, 1)
            End If
        Next
        
        ListBox1.RowSource = ""
        ListBox1.Clear
        If Say > 0 Then ListBox1.Column = Data
        Label4.Caption = " Listelenen Kayıt : " & ListBox1.ListCount
    Else
        ListBox1.RowSource = "LİSTE!A3:B" & S1.Cells(Rows.Count, 1).End(3).Row
        Label4.Caption = " Listelenen Kayıt : " & ListBox1.ListCount
    End If
End Sub

 

[Korhan Ayhan]

Bu satırlar hatalı olmuş...

Data(1, Say) = S1.Cells(X, 1)
Data(1, Say) = S1.Cells(X, 1)

Aşağıdaki gibi düzeltiniz.

Data(1, Say) = S1.Cells(X, 1)
Data(2, Say) = S1.Cells(X, 2)

 

[Kavinsky]

Sayın hocam dediğiniz gibi düzelttim bu sefer hata verdi. Demek ki başka yerde de bir hata yaptım.

Private Sub TextBox1_Change()
    Dim X As Long, Say As Long
    Dim Aranan_LİSTE As String
    Dim Sorgulanan_LİSTE As String
    
    If TextBox1 <> "" Then
        Aranan_LİSTE = Evaluate("=UPPER(""" & TextBox1.Text & """)")
        
        ReDim Data(1 To 1, 1 To 2)
        
        For X = 1 To S1.Cells(Rows.Count, 1).End(3).Row
            Sorgulanan_LİSTE = Evaluate("=UPPER(""" & S1.Cells(X, 1).Text & """)")
            
            If InStr(1, Sorgulanan_LİSTE, Aranan_LİSTE, vbTextCompare) > 0 Then
                Say = Say + 1
                ReDim Preserve Data(1 To 1, 1 To Say)
                Data(1, Say) = S1.Cells(X, 1)
                Data(2, Say) = S1.Cells(X, 2) 
            End If
        Next
        
        ListBox1.RowSource = ""
        ListBox1.Clear
        If Say > 0 Then ListBox1.Column = Data
        Label4.Caption = " Listelenen Kayıt : " & ListBox1.ListCount
    Else
        ListBox1.RowSource = "LİSTE!A3:B" & S1.Cells(Rows.Count, 1).End(3).Row
        Label4.Caption = " Listelenen Kayıt : " & ListBox1.ListCount
    End If
End Sub

Bu ÇAlışma kitabının içindeki kodlar

Option Explicit

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim S1 As Worksheet, BUL As Range
    
    If Intersect(Target, Range("A1:B30")) Is Nothing Then Exit Sub
    
    Cancel = True
    
    If Target <> "" Then
        Application.EnableEvents = False
        Set S1 = Sheets("LİSTE")
        If WorksheetFunction.CountIf(S1.Range("A:B"), "*" & Target & "*") = 1 Then
            Set BUL = S1.Cells.Find(Target)
            If Not BUL Is Nothing Then
                Target = BUL.Value
            End If
        Else
            ANIMSATICI
        End If
        Set S1 = Nothing
        Set BUL = Nothing
    Else
        ANIMSATICI
    End If
    
Son:
    Application.EnableEvents = True
End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    Dim S1 As Worksheet, BUL As Range
    
    If Intersect(Target, Range("A1:B30")) Is Nothing Then Exit Sub
    
    On Error GoTo Son
    
    If Target.Cells.Count > 1 Then Exit Sub

    If Target <> "" Then
        Application.EnableEvents = False
        Target.Select
        Set S1 = Sheets("LİSTE")
        If WorksheetFunction.CountIf(S1.Range("A:B"), "*" & Target & "*") = 1 Then
            Set BUL = S1.Cells.Find(Target)
            If Not BUL Is Nothing Then
                Target = BUL.Value
            End If
        Else
            ANIMSATICI
        End If
        Set S1 = Nothing
        Set BUL = Nothing
    End If
    
Son:
    Application.EnableEvents = True
End Sub

 

[Korhan Ayhan]

Aşağıdaki satırlarda bold olan kısımları 2 yapınız.

ReDim Data(1 To 1, 1 To 2)
ReDim Preserve Data(1 To 1, 1 To Say)

 

[Kavinsky]

Çok teşekkür ederim üstadım oldu.