Kod hata (?)

[Yaren Eslem]

Set Cell = .Find(What:=Search, after:=.SpecialCells(xlCellTypeLastCell), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchOrder:=xlByColumns)

Acaba ne demek istiyor bana?

Kodun tamamı;

Option Compare Text
Option Explicit

Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long

Const SM_CXSCREEN = 0
'Gets screen size to adjust column display
Private Function ScreenWidth()
    ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
End Function

Sub DoFindAll()
    'Arguements required for initial use in a workbook
    FindAll "", "True"
End Sub


Public Sub FindAll(Search As String, Reset As Boolean)


Dim WB              As Workbook
Dim ws              As Worksheet
Dim Cell            As Range
Dim Prompt          As String
Dim Title           As String
Dim FindCell()      As String
Dim FindSheet()     As String
Dim FindWorkBook()  As String
Dim FindPath()      As String
Dim FindText()      As String
Dim Counter         As Long
Dim FirstAddress    As String
Dim Path            As String
Dim MyResponse      As VbMsgBoxResult

    If Search = "" Then
        Prompt = "What do you want to search for in the worbook: " & vbNewLine & vbNewLine & Path
        Title = "Search Criteria Input"
        'Delete default search term if required
        Search = InputBox(Prompt, Title, "")
        If Search = "" Then
            GoTo Canceled
        End If
    End If
   
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
   
    'Save found addresses and text into arrays
    On Error Resume Next
    Set WB = ActiveWorkbook
    If Err = 0 Then
        On Error GoTo 0
        For Each ws In WB.Worksheets
            'Omit results page from search
            If ws.Name <> "FindWord" Then
                With WB.Sheets(ws.Name).Cells
                    Set Cell = .Find(What:=Search, after:=.SpecialCells(xlCellTypeLastCell), LookIn:=xlValues, LookAt:=xlPart, _
                        MatchCase:=False, SearchOrder:=xlByColumns)
                    If Not Cell Is Nothing Then
                        FirstAddress = Cell.Address
                        Do
                            Counter = Counter + 1
                            ReDim Preserve FindCell(1 To Counter)
                            ReDim Preserve FindSheet(1 To Counter)
                            ReDim Preserve FindWorkBook(1 To Counter)
                            ReDim Preserve FindPath(1 To Counter)
                            ReDim Preserve FindText(1 To Counter)
                            FindCell(Counter) = Cell.Address(False, False)
                            FindText(Counter) = Cell.Text
                            FindSheet(Counter) = ws.Name
                            FindWorkBook(Counter) = WB.Name
                            FindPath(Counter) = WB.FullName
                            Set Cell = .FindNext(Cell)
                        Loop While Not Cell Is Nothing And Cell.Address <> FirstAddress
                    End If
                End With
            End If
        Next
    End If
    On Error GoTo 0
    'Response if no text found
    If Counter = 0 Then
        MsgBox Search & " was not found.", vbInformation, "Zero Results For Search"
        Exit Sub
    End If
   
    'Create FindWord sheet in does not exist
    On Error Resume Next
    Sheets("FindWord").Select
    If Err.Number <> 0 Then
        'error occured so clear it
        Err.Clear
        Sheets.Add.Name = "FindWord"
        Sheets("FindWord").Move after:=Sheets(Sheets.Count)
        'Run macro to add code to ThisWorkbook
        AddSheetCode
    End If
   
    'Write hyperlinks and texts to FindWord
    Range("A3:B65536").ClearContents
    Range("A1:B1").Interior.ColorIndex = 6
    Range("A1").Value = "Occurences of:"
    'Reset prevents looping of code when sheet changes
    If Reset = True Then Range("B1").Value = Search
    Range("A1:D2").Font.Bold = True
    Range("A2").Value = "Location"
    Range("B2").Value = "Cell Text"
    Range("A1:B1").HorizontalAlignment = xlLeft
    Range("A2:B2").HorizontalAlignment = xlCenter
    'Adjust screen size to suit
    Range("A:A").ColumnWidth = ScreenWidth / 60
    Range("B:B").ColumnWidth = ScreenWidth / 10
    Range("C:C").ColumnWidth = ScreenWidth / 10
    For Counter = 1 To UBound(FindCell)
        ActiveSheet.Hyperlinks.Add Anchor:=Range("A" & Counter + 2), _
            Address:="", SubAddress:=Chr(39) & FindSheet(Counter) & Chr(39) & "!" & FindCell(Counter), _
            TextToDisplay:=FindSheet(Counter) & "!" & FindCell(Counter)
        Range("B" & Counter + 2).Value = FindText(Counter)
    Next Counter
    Range("B1").Select
   
Canceled:

    Set WB = Nothing
    Set ws = Nothing
    Set Cell = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
   
End Sub


Sub AddSheetCode()
    'Thanks to Dragontooth
    Dim strCode As String
    Dim FWord As String
    Dim WB As Workbook
    Dim Sh
    Dim i As Integer
    Set WB = ActiveWorkbook
   
    'Line to be inserted instead of 4th line below if code in Personal.xls
    '& "Application.Run (" & Chr(34) & "Personal.xls!Search.FindAll" & Chr(34) & "), Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
    'Optional 4th line if code in workbook
    '& "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _

    strCode = "Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)" & vbCr _
    & "If Sh.Name = " & Chr(34) & "FindWord" & Chr(34) & " Then" & vbCr _
    & "If Target.Address = " & Chr(34) & "$B$1" & Chr(34) & " Then" & vbCr _
    & "FindAll Target.Text, " & Chr(34) & "False" & Chr(34) & vbCr _
    & "Cells(1,2).Select" & vbCr _
    & "End if" & vbCr _
    & "End if" & vbCr _
    & "End Sub"
   
    'Write code to ThisWorkbook module
    FWord = "ThisWorkbook"
    For i = 1 To WB.VBProject.VBComponents.Count
        If WB.VBProject.VBComponents.Item(i).Name = FWord Then
            Exit For
        End If
    Next
    If Not WB.VBProject.VBComponents.Item(i).CodeModule Is Nothing Then
        If Not WB.VBProject.VBComponents.Item(i).CodeModule.Find("Workbook_SheetChange", 1, 1, 100, 100) Then
            WB.VBProject.VBComponents.Item(i).CodeModule.AddFromString (strCode)
        End If
    End If
    Set WB = Nothing
   
End Sub