problem with macro

[paulsolar]

Hi All

I'm having a strange problem with the below macro. The macro is an adaptation of a macro I found on this site created by Fluff


It has two problems
1
It is copying and pasting the wrong rows from from sheet1 to sheet2. It is copying rows where there is a 0 rather than 1 or over to sheet2 (what is stranger it is copying the correct number of rows and the ones it is copying are the same number of rows apart.
2
If I copy B:D it it actually copies C:E (hence in the code I have used A:C and this gives me B:D which is what I require)

Any ideas where i Have gone wrong??

Kind regards

Paul

Sub cleanup()
Dim rng As Range
Dim cell As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheet1
Set ws2 = Sheet2

Set rng = ws1.Range("B3:B49")

For Each cell In rng
    If cell.Value >= 1 Then
        cell.Range("A" & ActiveCell.Row & ":C" & ActiveCell.Row).Copy
        If ws2.Range("B16").Value = "" Then
            ws2.Range("B16").PasteSpecial xlPasteValues
        Else
            ws2.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
    End If
Next cell

End Sub

 

[offthelip]

try this:

Sub cleanup()
Dim rng As Range
Dim cell As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheet1
Set ws2 = Sheet2

Set rng = ws1.Range("B3:B49")

For Each cell In rng
    If cell.Value >= 1 Then
        cell.Range("A" & cell.Row & ":C" & cell.Row).Copy
        If ws2.Range("B16").Value = "" Then
            ws2.Range("B16").PasteSpecial xlPasteValues
        Else
            ws2.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
    End If
Next cell

End Sub

 

[paulsolar]

try this:

Sub cleanup()
Dim rng As Range
Dim cell As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheet1
Set ws2 = Sheet2

Set rng = ws1.Range("B3:B49")

For Each cell In rng
    If cell.Value >= 1 Then
        cell.Range("A" & cell.Row & ":C" & cell.Row).Copy
        If ws2.Range("B16").Value = "" Then
            ws2.Range("B16").PasteSpecial xlPasteValues
        Else
            ws2.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
    End If
Next cell

End Sub

Hi

Many thanks for your reply

I'm trying your reply and it seems to be copying rows not even related to the range now?

I cant seem to get my head around the at all now

cheers

Paul

 

[Fluff]

Hello Paul, how about

Sub cleanup()
Dim rng As Range
Dim cell As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheet1
Set ws2 = Sheet2

Set rng = ws1.Range("B3:B49")

For Each cell In rng
    If cell.Value >= 1 Then
        cell.Resize(, 3).Copy
        If ws2.Range("B16").Value = "" Then
            ws2.Range("B16").PasteSpecial xlPasteValues
        Else
            ws2.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
    End If
Next cell

End Sub

PS, Good wins for us both at the weekend ?

 

[paulsolar]

Hello Paul, how about

Sub cleanup()
Dim rng As Range
Dim cell As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Set ws1 = Sheet1
Set ws2 = Sheet2

Set rng = ws1.Range("B3:B49")

For Each cell In rng
    If cell.Value >= 1 Then
        cell.Resize(, 3).Copy
        If ws2.Range("B16").Value = "" Then
            ws2.Range("B16").PasteSpecial xlPasteValues
        Else
            ws2.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        End If
    End If
Next cell

End Sub

PS, Good wins for us both at the weekend ?

Hi Fluff

As always worked perfectly

I based my code on some code you had written previously but couldn't get it right.

England were superb I hate to say, we just squeezed past a poor Australian team. I think I will throw away my TV for the six nations and cut off any access to the internet, wooden spoon here we come, we'll perhaps not we may beat Italy

 

[Fluff]

Glad we could help & thanks for the feedback.

I think I will throw away my TV for the six nations

I wouldn't go that far, Wales have a habit of raising their. Especially when they play us.