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.Wor ksheets.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!