VBA code to copy some of the row cells based on match at column B

Question

My question might be common but unfortunately, I didn't find a code while searching to apply my needs exactly.

I have a table with huge data for agents' new deals and history. For sure some of the agents' names are repeated many times and some of their basic information stays the same every time. I need code to copy and paste automatically the basic information of the agent from some columns to the new row if I enter a matching name in column B As you can see in my test image below C4& C8 when I enter a name that is found before in column "b" I need to copy and paste columns "C,E,G,I,J,L,M,N" automatically to the new matching name row.

any suggestions, please.

Answer 1

A Worksheet Change: Match Value Above

• Copy the code into the sheet module e.g. Sheet1 (not ThisWorkbook and not Module1). Right-click the correct tab and select View Code.
• The code runs automatically when manually changing the values in column B starting in row 4.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    ' Define constants.
    Const FIRST_TARGET_CELL_ADDRESS As String = "B4"
    Const COPY_COLUMNS As String = "C,E,G,I,J,L,M,N"
    
    ' Reference the first cell and the initial range.
    Dim fcell As Range: Set fcell = Me.Range(FIRST_TARGET_CELL_ADDRESS)
    Dim rg As Range: Set rg = fcell.Resize(Me.Rows.Count - fcell.Row + 1)
    
    ' Reference the target range.
    Dim trg As Range: Set trg = Intersect(rg, Target)
    If trg Is Nothing Then Exit Sub
    
    ' Return the column strings in a String array.
    Dim CopyCols() As String: CopyCols = Split(COPY_COLUMNS, ",")
    
    ' To prevent retriggering this event when writing to the worksheet,
    ' disable events.
    ' To ensure that events get enabled, implement an error-handling routine.
    On Error GoTo ClearError
    Application.EnableEvents = False
    
    ' Declare additional variables.
    Dim tcell As Range, prow As Range, trow As Range
    Dim Value As Variant, CopyCol As Variant
    Dim RowsCount As Long, RowIndex As Long
    Dim HasPreviousEntry As Boolean
    
    ' Loop through the target cells.
    For Each tcell In trg.Cells
        ' Lookup the value in the target column.
        Value = tcell.Value
        HasPreviousEntry = False ' reset
        If Not IsError(Value) Then ' is no error
            If Len(Value) > 0 Then ' is no blank
                RowsCount = tcell.Row - fcell.Row + 1
                RowIndex = Application.Match(Value, Me.Range(fcell, tcell), 0)
                If RowIndex < RowsCount Then HasPreviousEntry = True
            End If
        End If
        ' Populate columns when the lookup is successful.
        If HasPreviousEntry Then
            Set trow = tcell.EntireRow
            Set prow = rg.Cells(RowIndex).EntireRow
            For Each CopyCol In CopyCols
                trow.Columns(CopyCol).Value = prow.Columns(CopyCol).Value
            Next CopyCol
        End If
    Next tcell
                            
ProcExit:
    Application.EnableEvents = True
    Exit Sub
ClearError:
    MsgBox "Run-time error [" & Err.Number & "]:" & vbLf & vbLf _
        & Err.Description, vbCritical
    Resume ProcExit
End Sub