Tüm Sayfalarda Arama ve Listeleme (Çözüldü)

[ozbinici07]

Merhaba Arkadaşlar Ekteki Örnekte Bulunan Arama İşleminde Tek "DATA" sayfasında arama yapmaktadır Diğer Tüm Sayfalarda da Arama Yapmasını Nasıl Sağlayabilirim ?


Ekli dosyayı görüntüle ÖRNEK DOSYA_01.zip

Private Sub CommandButton1_Click()
If OptionButton1.Value = True Then Call bul_59(TextBox2)
End Sub

Private Sub bul_59(ByVal txt As Control)
Dim sut As String, k As Range, adr As String, myarr(), a As Long
Dim sat As Long, deg
ListBox1.Clear
If txt.Text = "" Then Exit Sub
If txt.Name = "TextBox2" Then
    sut = "B"
    deg = txt.Text
   End If
sat = Sheets("Data").Cells(65536, sut).End(xlUp).Row
ReDim myarr(1 To 5, 1 To 65536)
Set k = Sheets("Data").Range(sut & "2:" & sut & sat). _
Find(deg & "*", , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do
        a = a + 1
        myarr(1, a) = Sheets("Data").Cells(k.Row, "B").Value
        myarr(2, a) = Sheets("Data").Cells(k.Row, "C").Value
        myarr(3, a) = Sheets("Data").Cells(k.Row, "D").Value
        myarr(4, a) = Sheets("Data").Cells(k.Row, "E").Value
        myarr(5, a) = Sheets("Data").Cells(k.Row, "F").Value
        Set k = Sheets("Data").Range(sut & "2:" & sut & sat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
    ReDim Preserve myarr(1 To 5, 1 To a)
    ListBox1.Column = myarr
End If
End Sub

Private Sub ListBox1_Click()
If ListBox1.ColumnCount = 0 Then Exit Sub
TextBox1.Text = ListBox1.Column(0)
TextBox3.Text = ListBox1.Column(1)
TextBox4.Text = ListBox1.Column(2)
TextBox5.Text = ListBox1.Column(3)
TextBox6.Text = ListBox1.Column(4)
End Sub

Private Sub TextBox2_Change()
TextBox2 = Evaluate("=upper(""" & TextBox2 & """)")
End Sub

Private Sub UserForm_Initialize()
ListBox1.ColumnCount = 5
ListBox1.ColumnWidths = "80;150;80;80;60"
OptionButton1.Value = True
TextBox2.SetFocus
End Sub

 

[ozbinici07]

Bu Konu Hakkında Bilgisi Olan Yokmu Hiç Acil Yardıma İhtiyaçım var.

 

[halit3]

Bu kodu bir dene

Private Sub bul_59(ByVal txt As Control)
Dim sut As String, k As Range, adr As String, myarr(), a As Long
Dim sat As Long, deg
ListBox1.Clear
If txt.Text = "" Then Exit Sub
If txt.Name = "TextBox2" Then
    sut = "B"
    deg = txt.Text
   End If

ReDim myarr(1 To 5, 1 To 65536)

'On Error Resume Next

For i = 1 To ActiveWorkbook.Sheets.Count
sayfa = Sheets(i).Name

sat = Sheets(sayfa).Cells(65536, sut).End(xlUp).Row
If Sheets(i).Name <> "aranamayacak sayfa adı" Then

Set k = Sheets(sayfa).Range(sut & "2:" & sut & sat). _
Find(deg & "*", , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do

        a = a + 1
        myarr(1, a) = Sheets(sayfa).Cells(k.Row, "B").Value
        myarr(2, a) = Sheets(sayfa).Cells(k.Row, "C").Value
        myarr(3, a) = Sheets(sayfa).Cells(k.Row, "D").Value
        myarr(4, a) = Sheets(sayfa).Cells(k.Row, "E").Value
        myarr(5, a) = Sheets(sayfa).Cells(k.Row, "F").Value
        Set k = Sheets(sayfa).Range(sut & "2:" & sut & sat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
   
End If

End If
Next
  ReDim Preserve myarr(1 To 5, 1 To a)
 ListBox1.Column = myarr

End Sub

 

[ozbinici07]

Bi Sorun Var Yanlız Arama Yapılan Kelime Bulunamayınca HATA Veriyor


Halit Bey Çok Teşekkür Ederim Günlerdir bu kodu çözmeye çalışıyordum sayenizde aradığımı buldum.:dua2:

Bu kodu bir dene

Private Sub bul_59(ByVal txt As Control)
Dim sut As String, k As Range, adr As String, myarr(), a As Long
Dim sat As Long, deg
ListBox1.Clear
If txt.Text = "" Then Exit Sub
If txt.Name = "TextBox2" Then
    sut = "B"
    deg = txt.Text
   End If

ReDim myarr(1 To 5, 1 To 65536)

'On Error Resume Next

For i = 1 To ActiveWorkbook.Sheets.Count
sayfa = Sheets(i).Name

sat = Sheets(sayfa).Cells(65536, sut).End(xlUp).Row
If Sheets(i).Name <> "aranamayacak sayfa adı" Then

Set k = Sheets(sayfa).Range(sut & "2:" & sut & sat). _
Find(deg & "*", , xlValues, xlWhole)
If Not k Is Nothing Then
    adr = k.Address
    Do

        a = a + 1
        myarr(1, a) = Sheets(sayfa).Cells(k.Row, "B").Value
        myarr(2, a) = Sheets(sayfa).Cells(k.Row, "C").Value
        myarr(3, a) = Sheets(sayfa).Cells(k.Row, "D").Value
        myarr(4, a) = Sheets(sayfa).Cells(k.Row, "E").Value
        myarr(5, a) = Sheets(sayfa).Cells(k.Row, "F").Value
        Set k = Sheets(sayfa).Range(sut & "2:" & sut & sat).FindNext(k)
    Loop While Not k Is Nothing And k.Address <> adr
   
End If

End If
Next
  ReDim Preserve myarr(1 To 5, 1 To a)
 ListBox1.Column = myarr

End Sub