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

Question

我已经在这个论坛上爬行了很长时间，但是由于通常已经提出并回答了问题，所以还没有发表评论！ 我是一个完整的新手，所以我的代码看起来很糟糕。

标题是我要做的基础。 其他问题使我能够找出前三点，但我无法循环。

1. 单元格E4：E（包含数据的最后一行）是我要查找的值
2. 在N4：N中（最后一行输入数据）。 找到后，选择并复制该单元格以及右边的下三个单元格。
3. 将它们粘贴到H：K（最后一行中有数据）。

4. 循环回到1.，但将行降低1，即E5，然后继续2.和3.，直到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

尝试：

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

这应该使您能够构建代码

Answer 2

我已经复制了您的代码，并陷入了我想找的循环中，还有一些小改动。

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