1. Use cell value to find value in range, 2. copy it & 3 cells to the right then 3. paste it in another range 4. loop

Question

I've been creeping this forum for ages but haven't yet commented as normally the questions have been asked and answered! I'm a complete newbie so my code will look awful.

The title is the basis of what I want to do. Other questions have allowed me to figure out the first 3. points but I'm unable to loop it.

1. Cell E4:E (last row with data in) is the value I am using to find
2. In N4:N (Last row with data in). Once found, select and copy that cell and the next three cells to the right.
3. Paste these in H:K (last row with data in).

4. Loop back to 1. but lower the row by 1 ie E5 and continue 2. & 3. until there is no data in the row of E:E.

    Sub Copy_cells() ' Copy_cells Macro Dim FindString As String Dim Rng As Range Dim Rng1 As Range Dim lastrow As Long FindString = ActiveSheet.Range("E4").Value lastrow = ActiveSheet.Range("H65536").End(xlUp).Row + 1 If Trim(FindString) <> "" Then With ActiveSheet.Range("N:N") Set Rng = .Find(What:=FindString, _ After:=.Cells(.Cells.Count), _ LookIn:=xlValues, _ Lookat:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlNext, _ MatchCase:=False) If Not Rng Is Nothing Then Application.Goto Rng, True ActiveCell.Resize(1, 4).Copy Destination:=ActiveSheet.Range("H" & lastrow) Else MsgBox "Nothing found" End If End With End If End Sub` 

Answer 1

Try:

Sub test()

Dim FindString As String
Dim Rng As Range
Dim Rng1 As Range
Dim lastrow As Long


lastrow_E = ActiveSheet.Range("E65536").End(xlUp).Row 'Set last row of E
First_E = 2 'First row in E
ActiveSheet.Range("$E$" & First_E & ":$E$" & lastrow_E).RemoveDuplicates Columns:=1, Header:=xlNo 'Remove duplicates from E

lastrow_E = ActiveSheet.Range("E65536").End(xlUp).Row 'reSet last row of E

lastrow = ActiveSheet.Range("H65536").End(xlUp).Row + 1 'Set last row of H
lastrow_checker = lastrow

lastrow_N = ActiveSheet.Range("N65536").End(xlUp).Row + 1 'Set last row of N

For Each c In Range("E" & First_E & ":E" & lastrow_E) 'loop E
    Found = 0
    FindString = ActiveSheet.Range(c.Address).Value 'Set findstring
    If Trim(FindString) <> "" Then 'make sure not blank
        For Each cell In Range("N1:N" & lastrow_N) 'loop N
            If cell.Value = FindString Then 'if cell = findstring
                Found_H = 0
                For Each ce In Range("H1:H" & lastrow) 'loop H if found
                    If ce.Value = FindString Then 'search for findstring in current list
                        Found_H = 1 'found set variable
                        Exit For
                    End If
                Next
                If Found_H = 0 Then 'if not found put it in
                    Range(cell.Address).Resize(1, 4).Copy Destination:=Range("H" & lastrow) 'resize, copy and paste
                    lastrow = lastrow + 1 'Increment lastrow for next value
                    Found = 1
                End If
                Found_H = 0
            End If
        Next
        If Found = 0 Then
            lastrow = lastrow + 1 'leave a blank row
        End If
    End If
Next

If lastrow = lastrow_checker Then
    MsgBox "Nothing Found"
End If
End Sub

This should get you on your way to be able to build your code

Answer 2

I've copied your code and stuck in the loop I think you're after, plus a couple of minor changes.

Sub Copy_cells()
' Copy_cells Macro

    Dim FindString As String
    Dim Rng As Range
    Dim Rng1 As Range
    Dim lastrow As Long
    Dim startrow As Long
    Dim intCount As Long

    startrow = 4
    lastrow = ActiveSheet.Range("H65536").End(xlUp).Row + 1

    For intCount = startrow To lastrow

        FindString = ActiveSheet.Range("E" & intCount).Value

        If Trim(FindString) <> "" Then
            With ActiveSheet.Range("N:N")
                Set Rng = .Find(What:=FindString, _
                                After:=.Cells(.Cells.Count), _
                                LookIn:=xlValues, _
                                Lookat:=xlWhole, _
                                SearchOrder:=xlByRows, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False)

                If Not Rng Is Nothing Then
                    Application.Goto Rng, True
                    ActiveCell.Resize(1, 4).Copy Destination:=ActiveSheet.Range("H" & lastrow)
                    'I'm not quite sure where you want to paste this back to??
                    'lastrow doesn't seem correct.. maybe use intCount?

                    'also this code probably works but could probably be rewritten as:
                    'Rng.Resize(1, 4).Copy Destination:=ActiveSheet.Range("H" & lastrow)
                Else
                    MsgBox "Nothing found"
                End If

            End With
        End If
    Next intCount

End Sub