DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Set k = Sheets(syf).[COLOR="Red"][B][I]Range("B:B")[/I][/B][/COLOR].Find(TextBox1.Value, , xlValues, xlPart, , 1)Set k = Sheets(syf).[COLOR="red"][B][I]Range("B:B")[/I][/B][/COLOR].FindNext(k)[FONT="Arial Narrow"][B][COLOR="Blue"]Private Sub CommandButton1_Click()[/COLOR][/B]
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)
[COLOR="blue"]Set k = Sheets(syf).Range("B:B").Find(TextBox1.Value, , xlValues, [COLOR="Red"]xlWhole[/COLOR], , 1)[/COLOR]
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.Font.Color = vbYellow: k.Font.Bold = True: k.Font.Italic = True
[COLOR="red"]Range(Cells(k.Row, "A"), Cells(k.Row, "H")).Interior.Color = vbRed[/COLOR]
Set k = Sheets(syf).[COLOR="Blue"]Range("B:B")[/COLOR].FindNext(k)[/COLOR]
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
[B][COLOR="blue"]End Sub[/COLOR][/B][/FONT]