Copy/Paste Cells based on a condition

[bowdown]

Hello folks,

I have the following issue and will be very grateful if you provide some help:

I have one sheet which I need to manipulate some data and copy/paste from it (sample below):

I need a script which searches for the word 'Open' in column A and next finds the first non-empty cell in the same column A (in this case A19) and then copies everything below this cell (including A19) to a new sheet. In other words, I need to copy from A19 going down the whole sheet (both rows and colums) to a new sheet.

 

[JoeMo]

Welcome to the Board!

Try this:

Sub bowdown()
Dim sSht As Worksheet, Fnd As Range, lR As Long
Set sSht = ActiveSheet
lR = Cells.Find(what:="*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
With sSht
    Set Fnd = .Range("A:A").Find(what:="Open", LookIn:=xlFormulas, lookat:=xlWhole)
    If Not Fnd Is Nothing Then
        Application.ScreenUpdating = False
        Set Fnd = Fnd.End(xlDown)
        .Range(Intersect(.Rows(Fnd.Row), .UsedRange), Intersect(.Rows(lR), .UsedRange)).Copy
        Sheets.Add after:=ActiveSheet
        With ActiveSheet
            .Range("A1").PasteSpecial Paste:=xlPasteAll
        End With
        sSht.Select
        Application.CutCopyMode = False
        .Range("A1").Select
    Else
        MsgBox "Open not found in column A"
    End If
End With
Application.ScreenUpdating = True
End Sub

 

[bowdown]

Thanks, JoeMo. Excellent work!! Keep it up!!!