Hey guys,
I had recieved some help with this code before in this forum, and I thought it was working perfectly but it turns out that in a certain instance it messes up. Hopefully someone can help edit this code so that it works in all circumstances, as I've pored over it for a while and can't figure out how to fix it.
Basically, this code looks for instances of groups of five 1s in a row in the H column and then copy and pastes those five 1s (plus the five 0s before it and the five 0s after it, if possible) into a new worksheet. If there aren't a total of five 0s before or after the five 1s, then it doesn't copy the 0s, only the 1s. Here are some examples to better explain what this program does.
If the H column looks like this: 0,0,0,0,0,1,1,1,1,1,0,0,0,0,0
Then it returns these rows: 0,0,0,0,0,1,1,1,1,1,0,0,0,0,0
If the H column looks like this: 1,1,0,0,0,1,1,1,1,1,0,0,0,0,0
Then it returns these rows: 1,1,1,1,1,0,0,0,0,0
If the H column looks like this: 0,0,0,0,0,1,1,1,1,1,0,0,1,1,1
Then it returns these rows: 0,0,0,0,0,1,1,1,1,1
If the H column looks like this: 1,1,1,0,0,1,1,1,1,1,0,0,0,1,1
Then it returns these rows: 1,1,1,1,1
The problem exists when there are instances of this: 0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0
If that instance occurs, the code will only return this: 0,0,0,0,0,1,1,1,1,1
What I want it to return is this: 0,0,0,0,0,1,1,1,1,1,1,1,1,1,1,0,0,0,0,0
If there are 2 groups of five 1s in a row, then the program now just skips the second group and any subsequent 0s after it. That is the problem I am trying to solve.
Here is the code as it stands now:
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 SumFirstFive As Long, SumOnes As Long, SumLastFive As Long
Dim Cell As Range, rngCopy As Range
Set wsDestination = Sheets("Sheet1")
RowOffsetPlus = 4
DestRowNo = wsDestination.Range("A" & Rows.Count).End(xlUp).Row + 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 < 5 Then
RowOffsetMinus = -Cell.Row + 1
Else
RowOffsetMinus = -RowOffsetPlus - 1
End If
SumFirstFive = WorksheetFunction.Sum(Range(Cell.Offset(RowOffsetMinus, 0), Cell.Offset(-1, 0)))
SumOnes = WorksheetFunction.Sum(Range(Cell, Cell.Offset(4, 0)))
SumLastFive = WorksheetFunction.Sum(Range(Cell.Offset(RowOffsetPlus + 1, 0), Cell.Offset(2 * RowOffsetPlus + 1, 0)))
Select Case True
Case SumFirstFive = 0 And SumOnes = 5 And SumLastFive = 0
Range(Cell.Offset(RowOffsetMinus, 0), Cell.Offset(2 * RowOffsetPlus + 1, 0)).EntireRow.Copy wsDestination.Range("A" & DestRowNo)
Case SumFirstFive = 0 And SumOnes = 5 And SumLastFive > 0
Range(Cell.Offset(RowOffsetMinus, 0), Cell.Offset(RowOffsetPlus, 0)).EntireRow.Copy wsDestination.Range("A" & DestRowNo)
Case SumFirstFive > 0 And SumOnes = 5 And SumLastFive = 0
Range(Cell, Cell.Offset(2 * RowOffsetPlus + 1, 0)).EntireRow.Copy wsDestination.Range("A" & DestRowNo)
Case SumFirstFive > 0 And SumOnes = 5 And SumLastFive > 0
Range(Cell, Cell.Offset(4, 0)).EntireRow.Copy wsDestination.Range("A" & DestRowNo)
End Select
DestRowNo = wsDestination.Range("A" & Rows.Count).End(xlUp).Row + 1
Set Cell = Cell.Offset(5, 0)
Set Cell = .FindNext(Cell)
If Cell.Address = FirstAddress Then Exit Do
Loop
End If
End With
End Sub
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
I've also attached data that has instances of these 2 groups of five 1s in a row so as to better explain this situation. However, I also need this code to function if there are more than 2 groups of five 1s in a row (3 groups, 4 groups, etc.)
Thanks for your help, I can't figure out for the life of me what to change in this code. Any help is appreciated
P.S. Here's a link to my original thread: http://www.excelforum.com/excel-prog...tatements.html
Bookmarks