Cinema
04-07-2016, 02:06 AM
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.Wor ksheets.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
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.Wor ksheets.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