1.使用单元格值查找范围内的值，2.复制并在右边添加3个单元格，然后3.将其粘贴到另一个范围内4.循环

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