Bul Makrosu Eksİk ÇaliŞiyor

[alicanxy58]

SAYFADAKİ VERİLERİ BULMAK İSTİYORUM ANCAK AŞAĞIDAKİ KOD İLE SADECE BİRİNİ SEÇEBİLİYORUM. AYRICA ARAMA YAPTIĞIM SAYFA BAŞKA BİR SAYFADAN EŞİTTİR FORMULÜ İLE GELİYOR CTRL+F İLE ARAMA YAPIYORUM ARADIĞIM VERİLER GÖRÜLMESİNE RAĞMEN ARAMA SONUÇ VERMİYOR.
YARDIMLARINIZA ŞİMDİDEN TEŞEKKÜRLER.




Sub Düğme1_Tıklat()
On Error Resume Next
bul = Application.InputBox("Aranılan Kelimeyi Yazın", Application.UserName)
Cells.Find([bul]).Select
For s = 1 To 4000
ActiveCell.Interior.ColorIndex = 40
Next
ActiveCell.Interior.ColorIndex = 0
End Sub

 

[Orion1]

Bulunacak veriyi beli bir aralıkta ararsanız bulunması daha çabuk olacaktır.Mesela hangi aralıkta aranacak?

 

[alicanxy58]

Sayfanin TÜmÜnde

 

[Orion1]

Ekli dosyayı inceleyiniz.
Listbox'ta listelenen veriye tıkladığınızda o veri seçilecektir.

Sub ara_bul()
ReDim myarr(1 To 2, 1 To 1)
bul = Application.InputBox("Aranılan Kelimeyi Yazın", Application.UserName)
If bul = "" Then Exit Sub
Cells.Interior.ColorIndex = xlNone
Cells.Font.ColorIndex = 0
Set c = Cells.Find(bul, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
    firstAddress = c.Address
    Do
    a = a + 1
    ReDim Preserve myarr(1 To 2, 1 To a)
        myarr(1, a) = c.Address
        myarr(2, a) = c
        Range(c.Address).Interior.ColorIndex = 3
        Range(c.Address).Font.ColorIndex = 6
        Set c = Cells.FindNext(c)
    Loop While Not c Is Nothing And c.Address <> firstAddress
End If
UserForm1.ListBox1.Column = myarr
UserForm1.Label1.Caption = "TOPLAM..:" & UserForm1.ListBox1.ListCount
UserForm1.Show
End Sub

 

[Seyit Tiken]

Aşağıdaki kodu deneyiniz.

Sub Düğme1_Tıklat()
Application.Dialogs(xlDialogFormulaFind).Show
End Sub

 

[alicanxy58]

sayın orion 2 bu saatte yardımınız için teşekkür ederim. bulunan bu hücreleri renklendirebilirmiyiz.

 

[Orion1]

sayın orion 2 bu saatte yardımınız için teşekkür ederim. bulunan bu hücreleri renklendirebilirmiyiz.

Dosyayı istediğiniz şekilde güncelledim.
4 nolu mesajdan indirebilirsiniz.

 

[alicanxy58]

sayın ORİON2 cevabınıza çok teşekkür ederim. Sayfanın herhangi bir sutununda arama yapmak için kodu nasıl düzenlemeliyiz.

 

[Orion1]

sayın ORİON2 cevabınıza çok teşekkür ederim. Sayfanın herhangi bir sutununda arama yapmak için kodu nasıl düzenlemeliyiz.

Aşağıdaki satırı onun altındaki satırla değiştirirseniz sadece A:B sütunlarında Arama yapar.

Set c = Cells.Find(bul, LookIn:=xlValues, LookAt:=xlWhole)

yukarıdaki satırı aşağıdaki satır ile değiştiriniz.

Set c = Range("A1:B65536").Find(bul, LookIn:=xlValues, LookAt:=xlWhole)

 

[alicanxy58]

sayın ORION2 denedim ama yine tamamında arama yapıyor bir şeyi eksikmi yapıyorum acaba..

 

[Orion1]

sayın ORION2 denedim ama yine tamamında arama yapıyor bir şeyi eksikmi yapıyorum acaba..

Aşağıdaki satırı sildinizmi?

Set c = Cells.Find(bul, LookIn:=xlValues, LookAt:=xlWhole)

 

[Orion1]

Aşağıdaki satırıda onun altındaki satırla değştirmek gerekiyor.

Set c = Cells.FindNext(c)

yukarıdaki satırı aşağıdaki satırla değiştiriniz.

Set c = Range("A1:B65536").FindNext(c)

 

[alicanxy58]

sayın ORION2 CEVAP ÇOK GÜZEL OLMUŞ ELİNİZE SAĞLIK.İYİ AKŞAMLAR

 

[Orion1]

sayın ORION2 CEVAP ÇOK GÜZEL OLMUŞ ELİNİZE SAĞLIK.İYİ AKŞAMLAR

Rica ederim.
İyi akşamlar.

 

[kurd27]

bu kodlardaki hatayı yardım!!!

ekli dosyadaki hatayı anlayamadım kodları duzelttim ama çalışmasında hata veriyor
nasıl düzeltebilirim yardım edebilirmisiniz.

Private Sub CommandButton1_Click()
Dim k As Range, ilk_adres As String, a As Long
Dim i As Long, syf As String
ListBox1.Clear
If TextBox1.Value = "" Then Exit Sub
ReDim myarr(1 To 2, 1 To 1)
For i = 0 To ListBox2.ListCount - 1
Sheets(ListBox2.Column(0, i)).Cells.Interior.ColorIndex = xlNone
Sheets(ListBox2.Column(0, i)).Cells.Font.Color = vbBlack
Sheets(ListBox2.Column(0, i)).Cells.Font.Bold = False
Sheets(ListBox2.Column(0, i)).Cells.Font.Italic = False
If ListBox2.Selected(i) = True Then
syf = ListBox2.Column(0, i)
Set k = Sheets(syf).Cells.Find(TextBox1.Value, , xlValues, xlPart, , 1)
If Not k Is Nothing Then
ilk_adres = k.Address
Do
a = a + 1
ReDim Preserve myarr(1 To 2, 1 To a)
myarr(1, a) = k.Address(False, False)
myarr(2, a) = k.Value
k.Interior.Color = vbRed
k.Font.Color = vbYellow
k.Font.Bold = True
k.Font.Italic = True
Set k = Sheets(syf).Cells.FindNext(k)
Loop While ilk_adres <> k.Address And Not k Is Nothing
End If
End If
Next i
Set k = Nothing
Label3.Caption = "Kriterlere Uyan " & Format(a, "#,##0") & " Adet Veri Bulundu..!!"
If a > 0 Then
ListBox1.Column = myarr
Erase myarr
MsgBox "Listeleme tamamlandı..!!", vbOKOnly + vbInformation, "ARA-BUL"
End If
If a < 1 Then MsgBox "Yazdığınız veriye uyan veri bulunamdı..!!", vbCritical, "DİKKAT"
TextBox1.Value = ""
TextBox1.SetFocus
End Sub

Private Sub ListBox1_Click()
If ListBox1.ListCount < 1 Then Exit Sub
Sheets(ListBox1.Column(1, ListBox1.ListIndex)).Select
Range(ListBox1.Column(1)).Select
End Sub

Private Sub OptionButton1_Click()
Dim i As Integer
If ListBox2.ListCount < 1 Then Exit Sub
For i = 0 To ListBox2.ListCount - 1
ListBox2.Selected(i) = True
Next
End Sub

Private Sub OptionButton2_Click()
Dim i As Integer
If ListBox2.ListCount < 1 Then Exit Sub
For i = 0 To ListBox2.ListCount - 1
ListBox2.Selected(i) = False
Next
End Sub

Private Sub UserForm_Click()

End Sub

Private Sub UserForm_Initialize()
Dim syf As Worksheet
For Each syf In Worksheets
ListBox2.AddItem syf.Name
Next
ListBox1.ColumnCount = 2
ListBox1.ColumnWidths = "30;200"
OptionButton1.Value = True
End Sub