VBA to copy mutiple ranges based on criteria

[Elvis]

Hi,

I have setup the code below in attempt to do a conditional copy of mutiple ranges/rows from one sheet to another but was wondering if there is a way copying the ranges in one go instead of having multiple if statements?

For example, for rows 5 to 10, I want to copy values in column B to N for each row and paste into the sheet result but only if column A of each row starts with or contains "1".

Would using some kind of union function be the best way of doing this?

Hope someone can help!

Thanks,

Elvis

Sub copyranges

Worksheets("Calculate").Select

If Left(Range("a5"), 1).Value = 1 Then

Range("B5:N5").Copy
Sheets("Results").Select
Range("a60000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If


If Left(Range("a6"), 1).Value = 1 Then

Range("B6:N6").Copy
Sheets("Results").Select
Range("a60000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If

If Left(Range("a7"), 1).Value = 1 Then

Range("B7:N7").Copy
Sheets("Results").Select
Range("a60000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If

If Left(Range("a8"), 1).Value = 1 Then

Range("B8:N8").Copy
Sheets("Results").Select
Range("a60000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If

If Left(Range("a9"), 1).Value = 1 Then

Range("B9:N9").Copy
Sheets("Results").Select
Range("a60000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If

If Left(Range("a10"), 1).Value = 1 Then

Range("B10:N10").Copy
Sheets("Results").Select
Range("a60000").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
End If

End Sub

 

[Sal Paradise]

Try this:

Sub copyranges()

    Dim i As Long
    
    With Worksheets("Calculate")
    
        For i = 5 To 10
            If Left(.Cells(i, 1), 1).Value = 1 Then
                .Range("B1:N1").Offset(i, 1).Copy
                Sheets("Results").Range("A65535").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
            End If
        Next i
    
    End With

End Sub

 

[AlphaFrog]

This tests if the value "contains" a 1

Sub copyranges2()

    Dim cell As Range, rng As Range
    
    For Each cell In Worksheets("Calculate").Range("A5:A10")
        If InStr(1, cell.Text, "1", 1) Then
            If rng Is Nothing Then
                Set rng = cell.Offset(, 1).Resize(, 13)
            Else
                Set rng = Union(rng, cell.Offset(, 1).Resize(, 13))
            End If
        End If
    Next cell
    
    rng.Copy Destination:=Sheets("Results").Range("A" & Rows.Count).End(xlUp).Offset(1)
    MsgBox "Data copied."

End Sub

 

[Elvis]

Thanks guys for the code.

Unfortunatley, the first one generates a run time error 424 stating object required. Debugging takes me to the following line:

If Left(.Cells(i, 1), 1).Value = 1 Then


The second code (copyranges2) generates a run time error 91 saying object variable or with block variable not set. This code actually pastes a few lines into the results sheets before generating the error but it does not look anything like the data I was eexpecting!

Any ideas what's going on?

Elvis

 

[Sal Paradise]

My bad. Try this:

Left(.Cells(i, 1), 1).Value

to

Left(.Cells(i, 1).Value, 1)