How to avoid to continue searching (on the same sheet) if specific word is found

[Cinema]

Hi,

I wrote a code that searches in every sheet a specific word and if there is a match it copies the cells right next to it.
But how I can avoid copying the cells if there is more than one time the same word on the same sheet. The searching and copying procedure should switch to the next sheet if the first word is found and copied.
The aim is to avoid double copies from the same sheet.


Here is my code.

Sub MakroTest()
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
Dim BoVorhanden As Boolean


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

 
 
sFind = InputBox("Please enter the word to search:")

For Each ws In Worksheets
    If ws.Name Like "Table*" 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, 2), Cell.End(xlToRight))
               rng.Copy Destination:=wsGraphics.Cells(row + 1, "B")
               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 ("No word found!")

End Sub

[SamT]

Consider what this bit of code is doing

Do 
                    row = row + 1 
                    Set rng = ws.Range(Cell.Offset(0, 2), Cell.End(xlToRight)) 
                    rng.Copy Destination:=wsGraphics.Cells(row + 1, "B") 
                    Set Cell = ws.Cells.FindNext(Cell) 
                    If Cell.Address = FirstFind.Address Then Exit Do 
                Loop

[Cinema]

row = row + 1
Set rng = ws.Range(Cell.Offset(0, 2), Cell.End(xlToRight))
rng.Copy Destination:=wsGraphics.Cells(row + 1, "B")
Set Cell = ws.Cells.FindNext(Cell)
If Cell.Address = FirstFind.Address


Now it works

[snb]

Sub M_snb() 
  if [not(isref(graphics!A1))] then sheets.add(,sheets(sheets.count)).name="graphics"
     
  c00 = InputBox("Please enter the word to search:") 
     
  On error resume next
  For Each sh In sheets 
    if instr(sh.name,"Table") Then sh.cells.find(c00,,,1).offset(,1)="B"
  next 
End Sub

[SamT]

  For Each ws In Worksheets 
        If ws.Name Like "Table*" Then 
            Set Cell = ws.Cells.Find(what:=sFind, lookat:=xlWhole, LookIn:=xlFormulas) 
            If Not Cell Is Nothing Then _
               ws.Range(Cell.Offset(0, 2), Cell.End(xlToRight)).Copy Destination:=wsGraphics.Cells(row + 1, "B") 
        End If 
    Next