Seçenekli Yenilene

[igultekin2000]

iyi günler;
veri sayfasının J sütunundaki verileri listele sayfasına getiriyorum.

Sub Yenilenendeger()
    Dim SD As Worksheet: Set SD = Sheets("VERI")
    Dim SO As Worksheet: Set SO = Sheets("listele")
    Dim liste(), dizi()
    son = SD.Cells(Rows.Count, "D").End(3).Row
    liste = SD.Range("J4:J" & son).Value
    Set dic = CreateObject("scripting.dictionary")
    For X = 1 To UBound(liste, 1)
        aranan = liste(X, 1)
        If Not dic.exists(aranan) Then
            dic.Add aranan, ""
        End If
    Next X
    SO.Range("B3:B" & Rows.Count).ClearContents
    SO.Range("B3").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

C1 Hücresine seçenek sunarak getirmem mümkün olurmu, yani 100 , 120 , 320 gibi yazdığında başı bu şekilde olan kodların gelmesi şeklinde. Teşekkürler

 

[EmrExcel16]

Bu şekilde mi istiyorsunuz .

Sub Yenilenendeger()
    Dim SD As Worksheet: Set SD = Sheets("VERI")
    Dim SO As Worksheet: Set SO = Sheets("listele")
    Dim liste(), dizi()
    son = SD.Cells(Rows.Count, "D").End(3).Row
    liste = SD.Range("J4:J" & son).Value
    Set dic = CreateObject("scripting.dictionary")
    For X = 1 To UBound(liste, 1)
        aranan = liste(X, 1)
        If aranan Like CStr("*" & [C1] & "*") Then
            If Not dic.exists(aranan) Then
                dic.Add aranan, ""
            End If
        End If
    Next X
    SO.Range("B3:B" & Rows.Count).ClearContents
    SO.Range("B3").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

 

[EmrExcel16]

Yada bu şekilde .
Sadece ilk 3 karakteri sorgular.

Sub Yenilenendeger()
    Dim SD As Worksheet: Set SD = Sheets("VERI")
    Dim SO As Worksheet: Set SO = Sheets("listele")
    Dim liste(), dizi()
    son = SD.Cells(Rows.Count, "D").End(3).Row
    liste = SD.Range("J4:J" & son).Value
    Set dic = CreateObject("scripting.dictionary")
    On Error Resume Next
    For X = 1 To UBound(liste, 1)
        aranan = liste(X, 1)
        If Left(aranan, 3) Like [C1] Then
            If Not dic.exists(aranan) Then
                dic.Add aranan, ""
            End If
        End If
    Next X
    SO.Range("B3:B" & Rows.Count).ClearContents
    SO.Range("B3").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

 

[igultekin2000]

Yada bu şekilde .
Sadece ilk 3 karakteri sorgular.

Sub Yenilenendeger()
    Dim SD As Worksheet: Set SD = Sheets("VERI")
    Dim SO As Worksheet: Set SO = Sheets("listele")
    Dim liste(), dizi()
    son = SD.Cells(Rows.Count, "D").End(3).Row
    liste = SD.Range("J4:J" & son).Value
    Set dic = CreateObject("scripting.dictionary")
    On Error Resume Next
    For X = 1 To UBound(liste, 1)
        aranan = liste(X, 1)
        If Left(aranan, 3) Like [C1] Then
            If Not dic.exists(aranan) Then
                dic.Add aranan, ""
            End If
        End If
    Next X
    SO.Range("B3:B" & Rows.Count).ClearContents
    SO.Range("B3").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

Yada bu şekilde .
Sadece ilk 3 karakteri sorgular.

Sub Yenilenendeger()
    Dim SD As Worksheet: Set SD = Sheets("VERI")
    Dim SO As Worksheet: Set SO = Sheets("listele")
    Dim liste(), dizi()
    son = SD.Cells(Rows.Count, "D").End(3).Row
    liste = SD.Range("J4:J" & son).Value
    Set dic = CreateObject("scripting.dictionary")
    On Error Resume Next
    For X = 1 To UBound(liste, 1)
        aranan = liste(X, 1)
        If Left(aranan, 3) Like [C1] Then
            If Not dic.exists(aranan) Then
                dic.Add aranan, ""
            End If
        End If
    Next X
    SO.Range("B3:B" & Rows.Count).ClearContents
    SO.Range("B3").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
End Sub

Elinize sağlık, teşekkür ederim. diğeri için düşünmüştüm ama bu başka makroda da kullanabileceğim şekilde olmuş, iyi çalışmalar

 

[EmrExcel16]

Elinize sağlık, teşekkür ederim. diğeri için düşünmüştüm ama bu başka makroda da kullanabileceğim şekilde olmuş, iyi çalışmalar

Rica ederim , istediğiniz gibi kullanabilirsiniz , iyi çalışmalar.