Copy cells to new worksheet if cell contains "Keep", skip blank "" cells

Hello Jinglelocks,

I believe the procedure below will do what you intended. Before running the code be sure to understand and modify the values of the four constants at the top of the procedure and, of course, the definition of the two worksheets just below the variable declarations.

I don't know how your data are structured but if TestClm (that is the column where you write "Keep") is the last column of your data you might avoid having it copied to the new sheet by setting LastClm =4.

Sub CopyIfKeepExample()

    Const TestClm   As Long = 5             ' column E: change to suit
    Const SetCount  As Long = 5             ' rows per data set: change to suit
    Const FirstRow  As Long = 2             ' change to suit
    Const LastClm   As Long = 7             ' change to suit

    Dim WsS         As Worksheet            ' Source
    Dim WsT         As Worksheet            ' Target (destination)
    Dim SrcData     As Variant              ' Data from WsS
    Dim OutData     As Variant              ' Data to keep
    Dim LastRow     As Long
    Dim Rng         As Range                ' for intermediate use
    Dim Rs          As Long                 ' loop counter: source rows
    Dim Rt          As Long                 ' counting OutData rows
    Dim R           As Long                 ' loop counter: copying rows
    Dim C           As Long                 ' loop counter: copy columns


    Set WsS = Sheet11
    Set WsT = Sheet17

    With WsS
        ' first used cell in column A, looking from sheet bottom up
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set Rng = .Range(.Cells(1, 1), .Cells(LastRow, LastClm))
'        Debug.Print WsS.Name, Rng.Address       ' for verification test only
        ' Reading from the sheet is slow. So we read only once.
        SrcData = Rng.Value                        ' read all data from WsS
    End With

    ' make the output array the same size as the input but transposed
    ReDim OutData(1 To UBound(SrcData, 2), 1 To UBound(SrcData))

    For Rs = FirstRow To LastRow Step SetCount
        ' compare case insensitive
            ' You might just check if the cell is blank
        If StrComp(SrcData(Rs + SetCount - 1, TestClm), "keep", vbTextCompare) = 0 Then
            ' transfer data to OutData array
            For R = 0 To SetCount - 1
                Rt = Rt + 1
                For C = 1 To LastClm
                    OutData(C, Rt) = SrcData(Rs + R, C)
                Next C
            Next R
        End If
    Next Rs

    ' delete blank rows at the end of the OutData array
    ReDim Preserve OutData(1 To UBound(OutData), 1 To Rt)

    With WsT
        ' don't over-write any existing data
        LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        ' make Rng the same size as OutData
        Set Rng = .Cells(LastRow + 1, "A").Resize(Rt, LastClm)
        ' Write OutData to Rng
        Rng.Value = Application.Transpose(OutData)
        .Activate
    End With
End Sub

Did you find the answer for your question? becsause I have the same situation and trying to find where I can read higly professional advice. 

productivity monitoring software
https://www.worktime.com/increase-employee-productivity-worktime