For each... in doesn't loop properly

[chi90]

Hi everyone,

this is my first post so I apologize in advance for any mistakes I can make posting.

Here's my problem: I wrote a macro to loop through a range of cells and then, if the cells' value is more than 0, to copy the cell and the adjacent ones to another sheet.
The problem is that it works only for the last positive cell in the range. So, it checks all the cells but only copy the last set of cells.
I hope I've made it clear
I searched the forum but couldn't find anything to help me.
Thanks in advance!

Sub ARCHIVE2()
    
   Application.ScreenUpdating = False
 
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim r1 As Range
    Dim r2 As Range


    Set wb1 = ActiveWorkbook
    Set wb2 = Workbooks("Archive")


    Set sh1 = wb1.ActiveSheet
    Set sh2 = wb2.Worksheets("Sheet1")
    
lMaxRows = sh2.Cells(Rows.Count, "E").End(xlUp).Row


    Set r1 = sh1.Range("o4:o54")


    Set r2 = sh2.Range("e" & lMaxRows + 1)
        Dim c As Range
    
    For Each c In r1
    On Error Resume Next
'test if cell is empty
        If c.Value > "0" Then
            'copy adjacent cells
            c.Resize(, 7).Copy
            r2.PasteSpecial Paste:=xlValues
             
        End If
        Next c
        
 Application.ScreenUpdating = True


End Sub

 

[Fluff]

Well done