PDA

View Full Version : [SOLVED] Search string multiple sheets copy row to new sheet



please_help
02-11-2021, 06:41 PM
Can someone please help me modify the code to
copy only the row with search string "IF" the cell in
Sheet.Columns(6) is greater than zero?


Thanks in advance



Option Explicit
Option Compare Text '< ignore case
'
Sub SearchSheets()
'
Dim FirstAddress As String, WhatFor As String
Dim Cell As Range, Sheet As Worksheet
'
WhatFor = InputBox("What are you looking for?", "Search Criteria")
If WhatFor = Empty Then Exit Sub
'
For Each Sheet In Sheets
If Sheet.Name <> "SEARCH" Then
With Sheet.Columns(7)
Set Cell = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
Cell.EntireRow.Copy _
Destination:=Sheets("SEARCH").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
End With
End If
Next Sheet
'
Set Cell = Nothing
End Sub

Paul_Hossler
02-11-2021, 07:17 PM
Try something like this

If it doesn't work for you, come on back with details



Option Explicit
Option Compare Text


Sub SearchSheets()
Dim FirstAddress As String, WhatFor As String
Dim c As Range, ws As Worksheet

WhatFor = InputBox("What are you looking for?", "Search Criteria")


If WhatFor = Empty Then Exit Sub


For Each ws In Worksheets
If ws.Name <> "SEARCH" Then
With ws.Columns(7)


Set c = .Find(WhatFor, LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
FirstAddress = c.Address

Do
If c.EntireRow.Cells(1, 6).Value > 0 Then
c.EntireRow.Copy _
Destination:=Worksheets("SEARCH").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End If
Set c = .FindNext(c)
Loop Until c Is Nothing Or c.Address = FirstAddress
End If
End With
End If
Next ws


Set c = Nothing


End Sub

please_help
02-11-2021, 07:24 PM
Thank you so much. Works Great.