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]

Hi & Welcome to the board

Your code is copying everything, it's just that everytime it finds a value in c it overwrites the previous value. To stop this you'll need to increment the row number of the paste range by 1 for every value found in c, as below.

lMaxRows = sh2.Cells(Rows.Count, "E").End(xlUp).Row


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

        Dim c As Range
    i = 1
    For Each c In r1
'test if cell is empty
        If c.Value > "0" Then
            'copy adjacent cells
            c.Resize(, 7).Copy
            sh2.Range("E" & lMaxRows + i).PasteSpecial Paste:=xlValues
            i = i + 1
        End If
    Next c

HTH

 

[chi90]

Hi Fluff,
THANK YOU! Made my day! Works perfectly and I feel a bit stupid :D

Now I need to do it for 20 columns, could you suggest me a way to do it without writing the same thing 20 times?
It would be every seven columns,from column O to ER, always the same cells. Or I can just rewrite it, it's going to be a long macro

Thanks again, I was really going mad

 

[Fluff]

Hia
Not sure if I've understood you correctly, or not, but try this

 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 lMaxRows As Integer
    Dim i As Integer
    Dim ColRng As Integer
    Dim c 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

    For ColRng = 15 To 148 Step 7
        Set r1 = sh1.Range(sh1.Cells(4, ColRng), sh1.Cells(54, ColRng))
        i = 1
        For Each c In r1
            'test if cell is empty
            If c.Value > "0" Then
                'copy adjacent cells
                c.Resize(, 7).Copy
                sh2.Cells(lMaxRows + i, ColRng - 10).PasteSpecial Paste:=xlValues
                i = i + 1
            End If
        Next c
    Next ColRng
 Application.ScreenUpdating = True


End Sub

 

[chi90]

It works almost perfectly! The only thing is I would need the data pasted in the last row in the same column in the Archive sheet, (column E), while now it copies the data from different columns in different columns (so the cells starting in column O are in Archive-column E but the ones starting in column N are pasted in column L instead of E). But beside that it does exactly what I needed

 

[chi90]

It works almost perfectly! The only thing is I would need the data pasted in the last row in the same column in the Archive sheet, (column E), while now it copies the data from different columns in different columns (so the cells starting in column O are in Archive-column E but the ones starting in column N are pasted in column L instead of E). But beside that it does exactly what I needed

It's ok, I changed it and now it copies in column E. I really don't know how to thank you, you've helped me a great deal!

 

[Fluff]

Glad you managed to sort it and many thanks for the feedback.
Could you supply your amended code?
That way anyone looking at this thread in the future will see the full solution.

 

[chi90]

Here it is:

 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 lMaxRows As Integer
    Dim i As Integer
    Dim ColRng As Integer
    Dim c 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
    i = 1
    For ColRng = 15 To 148 Step 7
        Set r1 = sh1.Range(sh1.Cells(4, ColRng), sh1.Cells(54, ColRng))
        
        For Each c In r1
        
            'test if cell is empty
            If c.Value > "0" Then
                'copy adjacent cells
                c.Resize(, 7).Copy
                sh2.Range("G" & lMaxRows + i).PasteSpecial xlPasteValuesAndNumberFormats
                i = i + 1
            End If
        Next c
    Next ColRng
 Application.ScreenUpdating = True




End Sub

I have now one last (I promise!) question, but it's not so important: I wanted to make it so that (even in a different macro) it copied the values in column C.
How can I do that? Basically it should do exactly the same, but instead of copying the adjacent cells it should stay on the same row and copy just one cell from column C.
It may be an easy fix but I couldn't find a way.

 

[Fluff]

Which cell in column C do you need to copy & where do you want to copy it to?

 

[chi90]

It's the cell in the same row as the one "analyzed". I solved it like this:

  Set r1 = sh1.Range(sh1.Cells(4, ColRng), sh1.Cells(54, ColRng))        
        For Each c In r1


            'test if cell is empty
            If c.Value > "0" Then
                c.Select
                sh1.Cells(ActiveCell.Row, 3).Copy
                sh2.Range("F" & lMaxRows + Z).PasteSpecial xlPasteValues
                Z = Z + 1
            End If
        Next c
    Next ColRng