Row copy loop when certain condition is met

[bombay121]

Hi Guys,

Second question of the day, I am a complete amateur at this so please bare with me. I've written the below code to copy and paste rows from one sheet to another when a certain value in a cell is found:

Range("H2").Select
Do Until IsEmpty(ActiveCell)
If ActiveCell.Text = "SS" Then
ActiveCell.EntireRow.Copy
End If
Worksheets("Sheet1").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Worksheets("DATA").Select
ActiveCell.Offset(1, 0).Select
Loop

It works to a certain extent but it pastes ten of each row it finds into Sheet 1. Could someone tell me where i'm going wrong?

Cheers
D

 

[JackDanIce]

Maybe this is what you want:

Dim i as Long
i = 2
With Sheets("DATA")
  Do Until IsEmpty(.Range("H" & i")
    If .Range("H" & i) = "SS" Then 
       .Rows(i).Copy
       Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row.Offset(1,0).Pastespecial xlPasteValues
    End If
i = i + 1
Loop

 

[bombay121]

Hi Jack,

It looks like its what I need but i'm getting a compile error on

Do Until IsEmpty(.Range("H" & i")

Sorry i'm a bit new at this.

D

 

[bombay121]

Hi guys,

So i've managed to fix the first problem, but am now having problems with this line:

Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row.Offset(1, 0).PasteSpecial xlPasteValues

I'm getting run-time error 424 object required, any idea what this means?

Thanks
D

 

[bombay121]

Hi Guys,

I've managed to solve the previous problem however I feel that the code is a bit long and there is a quicker way to write what i'm trying to do, here is the current code as it stands which works fine:

'Dim i As Long
'i = 2
'With Sheets("DATA")
'  Do Until IsEmpty(.Range("H" & i))
'    If .Range("H" & i) = "SS" Then
'       .Rows(i).Copy
'       Sheets("SS").Range("A" & Rows.Count).End(xlUp).Rows.Offset(1, 0).PasteSpecial xlPasteValues
'
'    ElseIf .Range("H" & i) = "HW" Then
'        .Rows(i).Copy
'        Sheets("HW").Range("A" & Rows.Count).End(xlUp).Rows.Offset(1, 0).PasteSpecial xlPasteValues
'
'    ElseIf .Range("H" & i) = "JC" Then
'        .Rows(i).Copy
'        Sheets("JC").Range("A" & Rows.Count).End(xlUp).Rows.Offset(1, 0).PasteSpecial xlPasteValues
'
'    ElseIf .Range("H" & i) = "OA" Then
'        .Rows(i).Copy
'        Sheets("OA").Range("A" & Rows.Count).End(xlUp).Rows.Offset(1, 0).PasteSpecial xlPasteValues
'
'    ElseIf .Range("H" & i) = "MM" Then
'        .Rows(i).Copy
'        Sheets("MM").Range("A" & Rows.Count).End(xlUp).Rows.Offset(1, 0).PasteSpecial xlPasteValues
'
'    ElseIf .Range("H" & i) = "LS" Then
'        .Rows(i).Copy
'        Sheets("LS").Range("A" & Rows.Count).End(xlUp).Rows.Offset(1, 0).PasteSpecial xlPasteValues
'
'    ElseIf .Range("H" & i) = "JM" Then
'        .Rows(i).Copy
'        Sheets("JM").Range("A" & Rows.Count).End(xlUp).Rows.Offset(1, 0).PasteSpecial xlPasteValues
'
' End If
' i = i + 1
' Loop
   
'End With

Now to make it more scaleable I was trying to use an array which is this:

Dim users As Variant
users = Array("SS", "HW", "JC", "OA", "LS", "JM")
With Sheets("DATA")
For intCounter = LBound(users) To UBound(users)
Dim i As Long
i = 2
Do Until IsEmpty(.Range("H" & i))
 
    .Range("H" & i) = " & users(intCounter) & "
        .Rows(i).Copy
        Sheets(users(intCounter)).Range("A" & Rows.Count).End(xlUp).Rows.Offset(1, 0).PasteSpecial xlPasteValues
 
Loop
 
i = i + 1
Next
End With

It doesn't quite behave how I want it to. It doesn't stop it just continuously loops through all the names overwriting anything on the first sheet (SS) and replacing the rows. Could anyone point out where I am going wrong?

Cheers
D