copy data by inputbox from sheet to another repeatedly and highlight data

Hi Leopard,

Your coding ambitions are becoming more sophisticated lol: Time to upgrade your skills to match. I hope you can handle the code below. If not, please ask for explanation.

Option Explicit

Enum Nws                    ' worksheet navigation (WsIn)
    ' 079
    ' if no value is assigned Excel presumes previous + 1
    NwsDate = 1             ' Date column (1 = "A")     - change as applicable (same in WsIn and WsOut)
    NwsBrand                ' Brand column (2 = "B")    - change as applicable
    NwsType                 ' Type column (3 = "C")     - change as applicable
    NwsLast = 7             ' colouring is applied from columns(1 : NwsLast)
End Enum

Sub TransferData()
    ' 079

    Dim WsIn        As Worksheet            ' data input sheet
    Dim WsOut       As Worksheet            ' data output sheet
    Dim Target      As Range                ' selected range
    Dim Dat         As Variant              ' selected date
    Dim Rs          As Long                 ' source row (in WsIn)
    Dim Rt          As Long                 ' target row (in WsOut)
    Dim R           As Long                 ' loop counter: rows

    ' Select one or more rows (columns don't matter)
    On Error Resume Next
    Set Target = Application.InputBox("Select what to transfer using the mouse", Type:=8)
    If Err Then Exit Sub
    
    On Error GoTo 0
    Set WsIn = Worksheets("Sheet1")         ' change name as appropriate
    Set WsOut = Worksheets("Sheet2")        ' change name as appropriate
    With Target
        If .Worksheet.Name <> WsIn.Name Then
            MsgBox "Please select a range in the" & vbCr & _
                   "worksheet '" & WsIn.Name & "'.", _
                   vbExclamation, "Wrong worksheet"
            Exit Sub
        End If

        ' specify the selected rows but from the Date column
        Set Target = Range(WsIn.Cells(.Row, NwsDate), _
                           WsIn.Cells(.Row + .Rows.Count - 1, NwsDate))
    End With

    With WsOut
        ' find the row to post copies to
        Rt = .Cells(.Rows.Count, NwsDate).End(xlUp).Row
    End With

    Application.ScreenUpdating = False
    With WsIn
        For R = 1 To Target.Rows.Count
            Rs = Target.Cells(R).Row        ' this is the sheet row
            If Not DataExists(.Cells(Rs, NwsDate).Value, _
                              .Cells(Rs, NwsBrand).Value, _
                              .Cells(Rs, NwsType).Value, _
                              WsOut) Then
                Rt = Rt + 1
                .Rows(Rs).Copy Destination:=WsOut.Cells(Rt, 1)
            End If
            .Cells(Rs, 1).Resize(1, NwsLast).Interior.Color = vbRed
        Next R
    End With
    Application.ScreenUpdating = True
End Sub

Private Function DataExists(ByVal Dat As Date, _
                            ByVal Brand As String, _
                            ByVal Typ As String, _
                            Ws As Worksheet) As Boolean
    ' 079
    ' return True if the specified data already exist in Ws

    Dim Fun         As Boolean              ' function return value
    Dim Rng         As Range                ' range to search for Dat
    Dim Fnd         As Range                ' Cell: match found
    Dim FirstFound  As Long                 ' location of first match

    With Ws
        ' set the range to search in (start in row 2)
        Set Rng = Range(.Cells(2, NwsDate), .Cells(.Rows.Count, NwsDate).End(xlUp))
    End With

    With Rng
        Set Fnd = .Find(Dat, .Cells(.Cells.Count), xlFormulas, xlWhole)
        If Not Fnd Is Nothing Then
            FirstFound = Fnd.Row
            Do
                Fun = (Trim(Ws.Cells(Fnd.Row, NwsBrand).Value) = Brand) And _
                      (Trim(Ws.Cells(Fnd.Row, NwsType).Value) = Typ)
                If Fun Then Exit Do
                Set Fnd = .FindNext(Fnd)
            Loop While Fnd.Row > FirstFound
        End If
    End With
    DataExists = Fun
End Function