copy row based on cell value

[mplees]

Hi,

I've been using the following code to highlight specific rows in my workbook - if a cell in column K contains 1, then the cell is highlighted in red

Dim CurCell as Range
Dim lRows as long

lRows = ActiveSheet.Rows.Count

For Each CurCell in ActiveSheet.Range("K:K")
      If CurCell.Value = 1 Then CurCell.Interior.ColorIndex = 3
Next CurCell

...which seems to work fine. What I need to do now however, is to copy each row that contains 1 in column K to another sheet in the workbook, & then clear the original contents. e.g if my data is on row 8, copy the data from A8:K8 to the next empty row on Sheet 2. I've been playing around, but haven't been able to find a way to do this correctly - can anyone assist?

Regards,

Mark

 

[Lewiy]

Try this:

Dim Limit As Long
Dim c As Long
Dim DestRow As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Set sh1 = Worksheets("Sheet1")
Set sh2 = Worksheets("Sheet2")
Limit = sh1.Cells(Rows.Count, 11).End(xlUp).Row
DestRow = sh2.Cells(Rows.Count, 1).End(xlUp).Row + 1
For c = Limit To 1 Step -1
    If sh1.Cells(c, 11) = 1 Then
        sh2.Range("A" & DestRow & ":K" & DestRow).Value = sh1.Range("A" & c & ":K" & c).Value
        sh1.Rows(c).Delete shift:=xlUp
        DestRow = DestRow + 1
    End If
Next c

 

[mplees]

Hi Lewiy,

Many thanks for that - works a treat!

Thanks again for your help,

Mark