What I'm doing wrong???

[Cinema]

Hi,

I wrote a macro that searches a word and copy the datas right next to it into the new worksheet I create at the beginning of the macro. I have two Problesms:
- the code does neither copy nor paste
- there could be more than once the same word and how I can search all of them and copy & paste the datas vertically row by row starting in Cells(1,1)

Option Explicit
Sub Makro1()
Dim wsNew As Worksheet
Dim ws As Worksheet
Dim rng As Range
Dim sAddress As String
Dim sFind As String
Dim BoVorhanden As Boolean

For Each ws In Worksheets
If ws.Name = "Graphics" Then
BoVorhanden = True
End If
Next ws
If BoVorhanden = False Then
Set wsNew = Worksheets.Add
With wsNew
.Name = "Graphics"
.Move after:=Sheets(Sheets.Count)
End With
Set wsNew = Nothing
End If

sFind = InputBox("Please enter word:")

For Each ws In Worksheets
If ws.Name Like "Tool*" Then
Set rng = ws.Cells.Find( _
what:=sFind, _
lookat:=xlWhole, _
LookIn:=xlFormulas)
If Not rng Is Nothing Then
Set rng = ws.Range(rng.Offset(0, 1), rng.End(xlToRight))
rng.Copy _
Destination:=Sheets("Graphics").Cells(1, 1)



End If
End If
Next ws
MsgBox prompt:="There aren't new words!"

End Sub

[Leith Ross]

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

[snb]

Sub M_snb()
  if [not(isref(Graphics!A1))] then sheets.add(,sheets(.sheets.count)).name="Graphics"

  c00 = InputBox("Please enter word:")
  on error resume next
  for each sh in sheets
    if left(sh.name,4)="Tool" then sheets("Graphics").cells(1)=sh.cells.find(c00,,1,1).offset(,1).value
  next
end sub

[Cinema]

Hi Leith Ross,

thank you for your help. This code works perfect. You are pro ! Thank you

[Cinema]

Hi snb,

thank you so much for your help. This code does also what I want.

[Cinema]

Hi Leith Ross,

i have still a Problem. The code does not create the sheet "graphics" if it does not exist. I am getting an "Error 91".

[Bob Phillips]

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.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 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

[Cinema]

Hi xld,


thank you so much!