如何根據單元格中的值復制行

Question

我正在嘗試編寫一個代碼，該代碼開始在特定列（D）中查找，然后在另一列（B）中查找以查看該特定文本是否已被使用（在B中）。

如果正在使用它，則應復制在相應B列中找到的整個行，並將其粘貼到開始查找的位置上方（D列中的那一行）。

在完成B列中的整個搜索之后，如果存在匹配項，則應刪除初始D行。 很有可能是添加了多行，因為B列中有多個匹配項。

我當前的代碼應該足以完成上述所有工作。 但是，似乎在cell命令上有問題（請參見下文）。 它表示存在故障： Rows(cellcheck).EntireRow.Copy

Sub run()

Dim rng As Range
Dim check As Range
Dim cell As Range
Dim cellcheck As Range
Dim Delyn As Long

Set rng = Range("D2:D2500")
Set check = Range("B2:B2500")

For Each cell In rng
    'Go through every cell in column D
    RT = cell.Row

    For Each cellcheck In check
        RC = cellcheck.Row
        'Go through every cell in column B

            If Cells(RC, "B").Value = Cells(RT, "D").Value Then
                'If the text in Column B is equal to Column D then do

                Rows(cellcheck).EntireRow.Copy
                'Copy the row which we found in column B
                Rows(cell + 1).Insert Shift:=xlDown
                'Paste it where we started in column D
                Cells(cell + 1, "B").Value = Cells(cell, "B")
                'Copy the name in column B of the initial cell into the new row
                Delyn = Delyn + 1
                'Add one to delete a row, so we know that we have to delete the row where we started this search
            End If
        Next cellcheck

    If Delyn > 0 Then
        'If we added new rows, we want to delete the reference row
        Rows(cell).Delete
        Delyn = 0
        'To avoid deletion for every row, we want to set this 0, until we find another reference in the B-column
    End If

Next cell

End Sub

任何幫助將非常感激。 我希望任何人都知道此代碼中的問題。

總結一下：它基本上應該遍歷2列，並復制B和D列之間的所有匹配項，並在使用的D行上方復制相應的B行，然后更改B列名稱並刪除D行。

Answer 1

謝謝大家的幫助。

如果有人對類似的編碼感興趣，那么最終的解決方案如下：

Sub Run()

Dim rng As Range
Dim check As Range
Dim cell As Range
Dim cellcheck As Range
Dim Delyn As Long

Set rng = Range("D2:D2500")
Set check = Range("B2:B2500")

For Each cell In rng
    'Go through every cell in column D
    RT = cell.Row

    For Each cellcheck In check
        RC = cellcheck.Row
        'Go through every cell in column B

            If Cells(RC, "B").Value = Cells(RT, "D").Value Then
                'If the text in Column B is equal to Column D then do

                cellcheck.EntireRow.Copy
                'Copy the row which we found in column B
                Rows(RT + 1).Insert Shift:=xlDown
                'Paste it where we started in column D
                Cells(RT + 1, "B").Value = Cells(RT, "B")
                'Copy the name in column B of the initial cell into the new row
                Delyn = Delyn + 1
                'Add one to delete a row, so we know that we have to delete the row where we started this search
            End If
        Next cellcheck

    If Delyn > 0 Then
        'If we added new rows, we want to delete the reference row
        Rows(RT).Delete
        Delyn = 0
        'To avoid deletion for every row, we want to set this 0, until we find another reference in the B-column
    End If

Next cell

End Sub

問題是我打電話給行，然后選擇整行（已經選擇）。 另一個小問題是調用單元格值（使用命令單元格），而不是詢問行號（使用RT或RC）。