Look at numbers between 2 numbers and copy the complete rows to a worksheet.

[bartman1980]

I have only number in column A.
It could be a 5 or a 6.
Example:
A1=5
A2=6
A3=6
A4=5
A5=6
A6=6
A7=5
A9=6
A10=6
A11=6
A12=6

Now I want to copy ALL the complete rows between the cells with a 5.
Result:
Rows 2 and 3 should be copied to worksheet 1 starting in row 5
Rows 5 and 6 should be copied to worksheet 2 starting in row 5
Rows 9, 10, 11 and 12 should be copied to worksheet 3 starting in row
5

The input of the cells in column A can be different each month.

Can somebody help me with a VBA code?

 

[Guest]

Here is another solution. Hope this works. Move the worksheet with the data
the 1st worksheet. The code below start at worksheet 2 so you are copying
the original data on worksheet(1) to new sheets starting at worksheet 2.


Sub completedrows()

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set ColARange = Range(Cells(1, "A"), Cells(Lastrow, "A"))

worksheetcount = 2
RowCount = 5
CellValue6 = False
For Each cell In ColARange

If cell.Value = 6 Then
CellValue6 = True
Rows(cell.Row & ":" & cell.Row).Copy Destination:= _
Sheets(worksheetcount).Rows(RowCount & ":" & RowCount)
RowCount = RowCount + 1
Else
If CellValue6 = True Then
worksheetcount = worksheetcount + 1
CellValue6 = False
RowCount = 5
End If
End If

Next cell


End Sub


Sub completedrows()

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
Set ColARange = Range(Cells(1, "A"), Cells(Lastrow, "A"))

worksheetcount = 1
RowCount = 5
CellValue6 = False
For Each cell In ColARange

If cell.Value = 6 Then
CellValue6 = True
Rows(cell.Row & ":" & cell.Row).Copy Destination:= _
Sheets(worksheetcount).Rows(RowCount & ":" & RowCount)
RowCount = RowCount + 1
Else
If CellValue6 = True Then
worksheetcount = worksheetcount + 1
CellValue6 = False
RowCount = 5
End If
End If

Next cell


End Sub

 

[Guest]

Try following code:

Sub SelectFive()
StartRow = 1
StopRow = 1
k = 2
For i = 1 To 65536
If Cells(i, 1).Value = 5 Then
StartRow = i + 1
Else
GoTo Nexti
End If
For j = i + 1 To 65536
If Cells(j, 1).Value = 5 Or Cells(j, 1).Value = "" Then
StopRow = j - 1
Exit For
End If
Next j
Rows(StartRow & ":" & StopRow).Copy Destination:=Worksheets("Sheet"
& k).Range("A5")
k = k + 1
If Cells(j, 1).Value = "" Then Exit Sub
Nexti:
Next i
End Sub

Regards
reklamo