Home Find a specific word in a cell and copy the rows next to it to another worksheet

# Find a specific word in a cell and copy the rows next to it to another worksheet

Numb3ers
1#
Numb3ers Published in 2018-02-14 15:18:56Z
 I would like to copy rows A-E whenever the word FLAG is found in row H and I want to skip all rows where Flag is not found. Below is example of the table I am working with and what I would want my result table to look like. This is the code I have, however it is not copying the rows A-E that have Flag it is just copying the first three rows to the new sheet. Sub foo() Dim ws As Worksheet: Set ws = Sheets("Duration") Dim wsResult As Worksheet: Set wsResult = Sheets("Report") LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 3 To LastRow For x = 8 To 8 If ws.Cells(i, x) = "FLAG" Then NextFreeRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1 ws.Range("A" & i & ":C" & i).Copy wsResult.Range("A" & NextFreeRow).PasteSpecial xlPasteAll ws.Cells(i, x - 4).Copy wsResult.Cells(NextFreeRow, 4).PasteSpecial xlPasteAll ws.Cells(i,x-3).Copy wsResult.Cells(NextFreeRow, 5).PasteSpecial xlPasteAll End If Next x Next i End Sub  Any help would be greatly appreciated!
Xabier
2#
 If you want to alter the copying from A to C to A to E, then this will do that: Sub foo() Dim ws As Worksheet: Set ws = Sheets("Duration") Dim wsResult As Worksheet: Set wsResult = Sheets("Report") LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row For i = 3 To LastRow If ws.Cells(i, 8) = "FLAG" Then NextFreeRow = wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Row + 1 ws.Range("A" & i & ":E" & i).Copy Destination:=wsResult.Range("A" & NextFreeRow) 'the code below will have to be amended if you changed your table's layout and you also want some other cells copied as well as A to E 'ws.Cells(i, 4).Copy 'wsResult.Cells(NextFreeRow, 6).PasteSpecial xlPasteAll 'ws.Cells(i, 5).Copy 'wsResult.Cells(NextFreeRow, 7).PasteSpecial xlPasteAll End If Next i End Sub 
 if you have to copy worksheet "Duration" columns A-E rows whose corresponding column H cell value is "Flag" and paste them to worksheet "Report" columns A-E starting form last not empty cell in column A, then go like this (explanations in comments): Option Explicit Sub foo() Dim wsResult As Worksheet: Set wsResult = Sheets("Report") With Worksheets("Duration") With .Range("A2:H" & .Cells(.Rows.Count, "A").End(xlUp).Row) 'reference its columns A:H cells from row 2 (header) down to last not empty one in column "A" .AutoFilter field:=8, Criteria1:="FLAG" ' filter referenced cells on 8thd column "FLAG" content If Application.WorksheetFunction.Subtotal(103, .Columns(8)) > 1 Then .Offset(1).Resize(.Rows.Count - 1, 5).SpecialCells(xlCellTypeVisible).Copy Destination:=wsResult.Cells(wsResult.Rows.Count, "A").End(xlUp).Offset(1) ' if any filtered cell other than the header then copy their first five columns and paste to 'wsResult' sheet starting from its column A last not empty cell End With .AutoFilterMode = False End With End Sub