DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub FindExactMatch()
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 metni girin !", "Arama..."))
If Not MyStr = "False" Then
Set FoundRng = Cells.Find(MyStr, LookIn:=xlValues, LookAt:=xlPart)
If Not FoundRng Is Nothing Then
Rng1 = FoundRng.Address
FoundRng.Select
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 ?"
ActiveCell.Interior.ColorIndex = 6
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.Select
GoTo ResumeSub2:
End If
Set FoundRng = Nothing
End Sub
Sub Test()
ActiveSheet.UsedRange.Select
Application.CommandBars.FindControl(ID:=1849).Execute
ActiveCell.Interior.ColorIndex = 6
ActiveCell.Select
End Sub
Sub Test2()
ActiveSheet.UsedRange.Select
Application.Dialogs(xlDialogFormulaFind).Show
ActiveCell.Interior.ColorIndex = 6
ActiveCell.Select
End Sub