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

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#
Xabier Reply to 2018-02-14 15:46:35Z

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
DisplayName
3#
DisplayName Reply to 2018-02-14 17:40:34Z

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
You need to login account before you can post.

About| Privacy statement| Terms of Service| Advertising| Contact us| Help| Sitemap|
Processed in 0.577716 second(s) , Gzip On .

© 2016 Powered by mzan.com design MATCHINFO