PDA

View Full Version : [SOLVED] How to avoid to continue searching (on the same sheet) if specific word is found



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

SamT
04-07-2016, 09:11 AM
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
04-08-2016, 01:11 AM
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
04-08-2016, 04:32 AM
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
04-08-2016, 07:44 AM
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