Arama çalışmıyor

[herdogan]

Arama bölümü çalışmıyor mu? Yoksa benin pc demi sorun var.

 

[irfancantr]

bilemiyorum ama istersen belki bu kod işini görür.Sayfana bir tane commandbutton ekle ve kodları içine yerleştir.

Dim MyStr As String, InfoMsg As String
Dim Rng1 As String, LookupValue As String
Dim MyQ As VbMsgBoxResult
Dim FoundRng As Variant
MyStr = Trim(Application.InputBox("Aranacak kelimeyi girin !", _
"Find exact match ..."))
If Not MyStr = "False" Then
Set FoundRng = Cells.Find(MyStr, LookIn:=xlValues, LookAt:=xlPart)
If Not FoundRng Is Nothing Then
Rng1 = FoundRng.Address
FoundRng.Activate
ResumeSub2:
If Right(FoundRng.Value, 1) <> " " Then LookupValue = FoundRng.Value & " "
MyData = Split(LookupValue, " ", , vbTextCompare)
For i = LBound(MyData) To UBound(MyData)
If MyData(i) = MyStr Then
InfoMsg = "Aranan metin " & FoundRng.Address(False, False) _
& " hücresinde bulundu." _
& vbCrLf & vbCrLf & "Bulunan hücrenin içeriği :" _
& vbCrLf & vbCrLf & FoundRng.Value & vbCrLf _
& vbCrLf & "Aramaya devam etmek istiyormusunuz ?"
MyQ = MsgBox(InfoMsg, vbInformation + vbYesNo, _
"Arama sonucu...")
If MyQ = vbYes Then GoTo ResumeSub1:
Exit Sub
End If
Next
Else
MsgBox "Aranan değer bulunamadı !", vbInformation, "Arama sonucu..."
Exit Sub
End If
ResumeSub1:
Set FoundRng = Cells.FindNext(FoundRng)
If Rng1 = FoundRng.Address Then
MsgBox "Aranan değerden başka bulunamadı !", vbInformation, _
"Arama sonucu..."
Exit Sub
End If
FoundRng.Activate
GoTo ResumeSub2:
End If
Set FoundRng = Nothing