• DİKKAT

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

Texboxta içeren süzme

A

ADER_34

Katılım
2 Haziran 2015
Mesajlar
349
Excel Vers. ve Dili
2010
Merhaba arkadaşlar kullandığım kodlarda texbox kutusuna örnek" BAD" yazdığımda
BAD içeren kelimer geliyor yani SCRAP_BAD BAD_RTV gibi

ben sadece BAD içeren gelmesi için kodda nasıl bir düzeltme yapmam gerekiyor kodlar

Sub Sonuçgetir()
Dim sh As Worksheet, sonsat As Long
Sheets("STOK_AKTAR").Select
Range("A3:M" & Rows.Count).ClearContents
Set sh = Sheets("SİSTEM_STOK")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
sh.Range("A1").AutoFilter
If TextBox1.Value <> "" Then
sh.Range("A1").AutoFilter field:=1, Criteria1:="*" & Sheets("STOK_AKTAR").TextBox1.Value & "*"
End If
If TextBox2.Value <> "" Then
sh.Range("A1").AutoFilter field:=2, Criteria1:="*" & Sheets("STOK_AKTAR").TextBox2.Value & "*"
End If
If TextBox3.Value <> "" Then
sh.Range("A1").AutoFilter field:=12, Criteria1:="*" & Sheets("STOK_AKTAR").TextBox3.Value & "*"
End If
If TextBox4.Value <> "" Then
sh.Range("A1").AutoFilter field:=6, Criteria1:="*" & Sheets("STOK_AKTAR").TextBox4.Value & "*"
End If
If TextBox5.Value <> "" Then
sh.Range("A1").AutoFilter field:=5, Criteria1:="*" & Sheets("STOK_AKTAR").TextBox5.Value & "*"
End If
If TextBox6.Value <> "" Then
sh.Range("A1").AutoFilter field:=4, Criteria1:="*" & Sheets("STOK_AKTAR").TextBox6.Value & "*"
End If
sh.Range("A1:E" & sonsat).CurrentRegion.Offset(1, 0).Copy Range("A3")
sh.Range("A1").AutoFilter


End Sub
 
Örnek dosya eklerseniz sorun nerde daha iyi çözülür.
 
Direkt textboxa çift tıklayıp aşağıdaki kodları ekleyin.
Kod: 
Private Sub TextBox1_Change()
Dim sh As Worksheet, sonsat As Long
Set sh = Sheets("SİSTEM_STOK")
sonsat = sh.Cells(Rows.Count, "A").End(xlUp).Row
Range("A3:M" & Rows.Count).ClearContents
Dim METİN1 As String, FC2 As Range
On Error Resume Next
METİN1 = TextBox1.Value
Set FC2 = sh.Range("a1:e65000").Find(What:=METİN1)
sh.Range("a1:e65000").AutoFilter Field:=1, Criteria1:="*" & TextBox1.Value & "*"
sh.Range("A1:E" & sonsat).CurrentRegion.Offset(1, 0).Copy Range("A3")
If METİN1 = "" Then
sh.Range("a1:e65000").AutoFilter Field:=3
Range("A3:M" & Rows.Count).ClearContents
End If
End Sub
 
Merhaba sayın askım benim amacım bu değil ilk mesajımı okursanız texbox kutusuna yazdığım kelime tam eşleşme ile aktarılsın istiyorum bu kodlar içene kelimeleri aktarıyor
 
...

Bu şekilde deneyiniz.

Kod: 
Sub aktar()
Dim s1 As Worksheet, s2 As Worksheet
Dim a(), aranan As String
Dim i As Long, say As Long, son As Long, j As Long
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")
son = s1.Range("A" & Rows.Count).End(3).Row
a = s1.Range("A2:E" & son)
aranan = Sheets("Sayfa2").TextBox1.Text
For i = 1 To UBound(a)
    If aranan = a(i, 1) Then
        say = say + 1
        For j = 1 To UBound(a, 2)
            a(say, j) = a(i, j)
        Next j
    End If
Next i
s2.Range("A3:E" & Rows.Count).ClearContents
If say > 0 Then
    s2.[A3].Resize(say, UBound(a, 2)) = a
End If
MsgBox "Aktarma işlemi tamam..", vbInformation
End Sub
 
Başında ve sonunda olan yıldızı silin.
 
Merhaba sayın Ziynettin kodlarınız sorunsuz çalışıyor,kendi dosyama uyarladım sizden bir isteğim daha olacak kendi dosyamı örnek olarak siteye yüklüyorum ürünleri Süzerken 3 tane Texbox olarak süzmek istiyorum değer RTV_TRANSFER sayfasına "Q R S T" sütunlarındaki değerlere bakarak süzmek istiyorum mümkünmü? kolaygelsin teşekkürler
http://s5.dosya.tc/server5/644oh0/RTV_ICIN_AYRIRARAK_GETIR.rar.html
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst