Hello Cinema,

Try this revision to your code and let me know the results.

Sub Makro1()

    Dim Cell        As Range
    Dim FirstFind   As Range
    Dim rng         As Range
    Dim row         As Long
    Dim sAddress    As String
    Dim sFind       As String
    Dim ws          As Worksheet
    Dim wsGraphics  As Worksheet

        On Error Resume Next
            Set wsGraphics = ThisWorkbook.Worksheets("Graphics")
            If Err = 9 Then
                Set wsGraphics = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets.Count)
                wsGraphics.Name = "Graphics"
            End If
        On Error GoTo 0

        sFind = InputBox("Please enter word:")

        For Each ws In Worksheets
            If ws.Name Like "Tool*" Then
                Set Cell = ws.Cells.Find(what:=sFind, lookat:=xlWhole, LookIn:=xlFormulas)
                If Not Cell Is Nothing Then
                    Set FirstFind = Cell
                    Do
                        row = row + 1
                        Set rng = ws.Range(Cell.Offset(0, 1), Cell.End(xlToRight))
                        rng.Copy Destination:=wsGraphics.Cells(row, "A")
                        Set Cell = ws.Cells.FindNext(Cell)
                        If Cell.Address = FirstFind.Address Then Exit Do
                    Loop
                End If
            End If
        Next ws
        
        If row = 0 Then MsgBox ("There aren't new words!")

End Sub