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