Find Duplicate Values and Export Rows into New Sheet

[sacaro]

I'm new to VBA, so please forgive me in advance.

What I have is two worksheets, one with all of my raw data (Base) and the other housing information submitted from a form (Sheet 1).

What I am trying to do is finding any duplicate ID numbers from column B in Sheet 1 that match the IDs in Column D in the Base data, and if so, then copy all of the row from the Base sheet into Column J of the matching ID row on Sheet 1.

I've tried the below code, which works to an extent with the following issues that I'm unsure of how to fix:

• Currently this code is looking for a fixed ID number (111467749), and I need this to instead look for duplicated IDs from Column B in sheet 1 that match Column D in Base.
• When deployed, it pastes the base data into a new row, instead of pasting it into the matching row, starting in column J.

Dim xRg As Range

Dim xCell As Range

Dim A As Long

Dim B As Long

Dim C As Long

A = Worksheets("Base").UsedRange.Rows.Count

B = Worksheets("Sheet1").UsedRange.Rows.Count

If B = 1 Then

If Application.WorksheetFunction.CountA(Worksheets("Sheet1").UsedRange) = 0 Then B = 0

End If

Set xRg = Worksheets("Base").Range("D1:D" & A)

On Error Resume Next

Application.ScreenUpdating = False

For C = 1 To xRg.Count

    If CStr(xRg(C).Value) = "111467749" Then

        xRg(C).EntireRow.Copy Destination:=Worksheets("Sheet1").Range("A" & B + 1)

        B = B + 1

    End If

Next

Application.ScreenUpdating = True

End Sub

 

[DanteAmor]

Hi and welcome to MrExcel

Try this:

Sub copyRows()
  Dim c As Range, f As Range
  Dim lc As Long
  
  With Sheets("Base")
    lc = .UsedRange.Columns(.UsedRange.Columns.Count).Column
    For Each c In .Range("D1", .Range("D" & Rows.Count).End(3))
      Set f = Sheets("Sheet1").Range("B:B").Find(c.Value, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        .Range("A" & c.Row, .Cells(c.Row, lc)).Copy Sheets("Sheet1").Range("J" & f.Row)
      End If
    Next
  End With
End Sub

 

[sacaro]

Hi and welcome to MrExcel

Try this:

Sub copyRows()
  Dim c As Range, f As Range
  Dim lc As Long
 
  With Sheets("Base")
    lc = .UsedRange.Columns(.UsedRange.Columns.Count).Column
    For Each c In .Range("D1", .Range("D" & Rows.Count).End(3))
      Set f = Sheets("Sheet1").Range("B:B").Find(c.Value, , xlValues, xlWhole, , , False)
      If Not f Is Nothing Then
        .Range("A" & c.Row, .Cells(c.Row, lc)).Copy Sheets("Sheet1").Range("J" & f.Row)
      End If
    Next
  End With
End Sub

Thank you so much for all of your help! This did the trick and worked beautifully!

 

[DanteAmor]

Im glad to help, thanks for the feedback.