This is untested, so make a copy of your workbook to test with. But I think
it'll work just fine for you. To put the code to work, open the copy of the
workbook, press [Alt]+[F11] to open the VB Editor then choose Insert-->Module
and copy and paste the code below into the module. Make any edits to the
Const values that you see are needed. Close the VB Editor, run the code
either from Tools --> Macro --> Macros (pre-2007) or from the Developer tab
in Excel 2007. You can give the Sub a more meaningful name if you want to.
Sub CopySpecificData()
'change these constants as required
'by having them defined here, you can
'change them here or in the future
'to adapt to other similar situations
Const sourceSheetName = "DATA"
Const firstColToCopy = "A"
Const lastColToCopy = "G"
Const firstRowWithData = 2
Const testColumn = "B"
'this is the destination sheet
Const destSheetName = "Status"
'phrases to test
'make these all UPPERCASE here in code
'and with NO leading/trailing blanks
Const phrase1 = "FAILED"
Const phrase2 = "NOT COMPLETED"
Const phrase3 = "NO RUN"
'you could add/delete from the list and
'simply adjust the code below
'end of user definable constants
Dim srcSheet As Worksheet
Dim testList As Range
Dim anyTestCell As Range
Dim copyRange As Range
Dim destSheet As Worksheet
Dim destCell As Range
Dim testPhrase As String
Set srcSheet = ThisWorkbook.Worksheets(sourceSheetName)
Set testList = srcSheet.Range(testColumn & _
firstRowWithData & ":" & _
srcSheet.Range(testColumn & Rows.Count).End(xlUp).Address)
Set destSheet = ThisWorkbook.Worksheets(destSheetName)
For Each anyTestCell In testList
If Not IsEmpty(anyTestCell) Then
testPhrase = UCase(Trim(anyTestCell))
If testPhrase = phrase1 Or _
testPhrase = phrase2 Or _
testPhrase = phrase3 Then
Set copyRange = _
srcSheet.Range(firstColToCopy & anyTestCell.Row & _
":" & lastColToCopy & anyTestCell.Row)
Set destCell = destSheet.Range(firstColToCopy & _
destSheet.Range(firstColToCopy & Rows.Count). _
End(xlUp).Offset(1, 0).Row)
copyRange.Copy
'this will past values, formulas & format
destCell.PasteSpecial xlPasteAll
'if you want just values & formats
'use these next 2 lines instead
'of the one above
'destCell.PasteSpecial xlPasteValues
'destCell.PasteSpecial xlPasteFormats
End If ' end of test for phrase matches
End If ' end IsEmpty test
Next ' end anyTestCell loop
'all done, do housekeeping
Set destCell = Nothing
Set copyRange = Nothing
Set testList = Nothing
Set destSheet = Nothing
Set srcSheet = Nothing
MsgBox "Task Completed", vbOKOnly + vbInformation, "Job Done"
End Sub
