This should do it:
Option Explicit
Sub ReportByKeywords()
Dim ws As Worksheet, wsNEW As Worksheet
Dim wrdARRAY As Variant, wrd As Long
Dim wrdFIND As Range, wrdFIRST As Range, wrdRNG As Range
Set wsNEW = Sheets.Add(After:=Sheets(Sheets.Count))
wrdARRAY = Array("Clinked", "Iron", "Alum", "South Africa", "China", "India")
For Each ws In Worksheets
If ws.Name Like "PORT*" Then
For wrd = LBound(wrdARRAY) To UBound(wrdARRAY)
Set wrdFIND = ws.Cells.Find(wrdARRAY(wrd), LookIn:=xlValues, LookAt:=xlPart)
If Not wrdFIND Is Nothing Then
Set wrdFIRST = wrdFIND
Do
If wrdRNG Is Nothing Then
Set wrdRNG = ws.Range("A" & wrdFIND.Row)
Else
Set wrdRNG = Union(wrdRNG, ws.Range("A" & wrdFIND.Row))
End If
Set wrdFIND = ws.Cells.FindNext(wrdFIND)
Loop Until wrdFIND.Address = wrdFIRST.Address
Set wrdFIRST = Nothing
Set wrdFIND = Nothing
End If
Next wrd
End If
If Not wrdRNG Is Nothing Then
wrdRNG.EntireRow.Copy wsNEW.Range("A" & Rows.Count).End(xlUp).Offset(1)
Set wrdRNG = Nothing
End If
Next ws
End Sub
LinkBack URL
About LinkBacks
Register To Reply
icon below to give reputation feedback, it is appreciated.
Bookmarks