Thread: Offset and If/Then Statements

Hey guys,

I'm pretty much halfway there with this program I am attempting to complete. What it does right now is finds every row that has a "1" in the "H" column and copy and pastes that row into a new worksheet. Here's the code for it.

Function Find_Range(Find_Item As Variant, _
    Search_Range As Range, _
    Optional LookIn As Variant, _
    Optional LookAt As Variant, _
    Optional MatchCase As Boolean) As Range
     
    Dim c As Range
    If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
    If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
    If IsMissing(MatchCase) Then MatchCase = False
     
    With Search_Range
        Set c = .Find( _
        What:=Find_Item, _
        LookIn:=LookIn, _
        LookAt:=LookAt, _
        SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, _
        MatchCase:=MatchCase, _
        SearchFormat:=False)
        If Not c Is Nothing Then
            Set Find_Range = c
            firstAddress = c.Address
            Do
                Set Find_Range = Union(Find_Range, c)
                Set c = .FindNext(c)
            Loop While Not c Is Nothing And c.Address <> firstAddress
        End If
    End With
     
End Function

Sub Find()
Find_Range(1, Columns("H"), xlFormulas, xlWhole).EntireRow.Copy Worksheets("Sheet1").Range("A1")
End Sub

What I also want the program to do is to copy the 5 rows before the "1" and the 5 rows after the "1" as well. I believe that this is possible using the Offset function to select other rows in relation to the row with the "1," however I've been having trouble getting it to work correctly.

The other thing about this program is that I don't want it to copy the 5 rows before or after the "1" if any of those rows have a "1" in them. I believe that this is possible using If/Then statements, but the tutorials I've read about using that have been very confusing and not very helpful.

Any help would be much appreciated guys. I have basically no experience using this program, so again I would be grateful for any tips or help. Thanks!

Try this

Option Explicit

Sub Find_Range(Find_Item As Variant, _
               Search_Range As Range, _
               Optional LookIn As Long = xlValues, _
               Optional LookAt As Long = xlPart, _
               Optional MatchCase As Boolean = False)

    Dim FirstAddress As String
    Dim wsDestination As Worksheet
    Dim DestRowNo As Long
    Dim RowOffsetMinus As Long, RowOffsetPlus As Long
    Dim Cell As Range, rngCopy As Range

    Set wsDestination = Sheets("Sheet2")

    RowOffsetPlus = 5
    DestRowNo = 1
    With Search_Range
        Set Cell = .Find(What:=Find_Item, _
                         LookIn:=LookIn, LookAt:=LookAt, _
                         SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                         MatchCase:=MatchCase, SearchFormat:=False)
        If Not Cell Is Nothing Then
            FirstAddress = Cell.Address
            Do
                If Cell.Row < 6 Then
                    RowOffsetMinus = -Cell.Row + 1
                Else
                    RowOffsetMinus = -RowOffsetPlus
                End If
                Range(Cell.Offset(RowOffsetMinus, 0), Cell.Offset(RowOffsetPlus, 0)).EntireRow.Copy wsDestination.Range("A" & DestRowNo)
                DestRowNo = wsDestination.Range("A" & Rows.Count).End(xlUp).Row + 1
                Set Cell = .FindNext(Cell)
                If Cell.Address = FirstAddress Then Exit Do
            Loop
        End If
    End With

End Sub

Sub CopyRange()
    Find_Range 1, Sheets("Sheet1").Columns("H"), xlFormulas, xlWhole
End Sub

Adjust the range refs and sheet names to suit your situation.

This is as it stands a bit dodgey.
1/. If the first instance of "1" is before Row 5 then you obviously cannot copy 5 rows before that, I have allowed for this situation by copying all the preceding rows.
2/. If instances of "1" are less than 11 rows apart then you will get duplication where the conditions overlap.

You used Ismissing(), that is one way to set optional values, my preference is to set the values in the Sub arguements, it's up to you how you want to do this.

When naming subs and functions it isn't a good idea to use names that are standard function names.

Hope this helps.

Marcol,

Thank you very much for your response! I tried what you said (using your code) and adjusted the sheet name to match what I needed in my data, but when I ran the program it ran without any errors but did not copy any of my data into the new sheet. However, I did not quite understand what you meant by "adjust the range refs." Perhaps I didn't set those correctly and that's why nothing got copied? Could you please elaborate on that point? Again, I very much appreciate the response, this has been frustrating me for the past week and I am at a loss at what to do.

EDIT: If you think it would be more helpful/easier, I could attach the data we are using this program with so we are both on the same page. Should I post it?

As long as the "1"s start no Higher than row 6 then you should get the range results you want by modifiing this one line in your code ....

FROM ...Set Find_Range = Union(Find_Range, c)

TO ...
Set Find_Range = Union(Find_Range, Range(Cells(c.Offset(-5, 0).Row, c.Column), Cells(c.Offset(5, 0).Row, c.Column)))

Does that help ?

I've attached one of our data sets. It is the raw data that we recieve from the tests we run. I chose this data set since I think it would be the easiest to work with (the rows with the 1s are spaced out). However, sometimes the data will have the 1s very close together. FYI, these rows of 1s will always be in sets of fives (five 1s in a row, you'll better understand if you look at the data).

EDIT: The 1s are in column H, under "CS."

What are you looking for as a result?

Is it rows that return this sequence
1/. 0,0,0,0,0,1,1,1,1,1,0,0,0,0,0
Or
2/. 0,0,0,0,0,1,1,1,1,1

This workbook returns the second option

Try this workbook

With the criteria given the result could have 10 or 15 consecutive 1s in certain situations, is that acceptable?

Change the calling macro to this

Sub CopyRange()
    Dim wsNo As Long

    For wsNo = 1 To Sheets.Count
        If Sheets(wsNo).Name <> "Sheet1" Then
            Find_Range 1, Sheets(wsNo).Columns("H"), xlFormulas, xlWhole
        End If
    Next
End Sub

This assumes that "Sheet1" is where you want the result written and appended for every sheet in the book.

There is also a change in the Sub Find_Range
This line

DestRowNo =  1

Now

DestRowNo = wsDestination.Range("A" & Rows.Count).End(xlUp).Row + 1

If the destination sheet is not "Sheet1" change to suit throughout the code.

See the attached.