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

0

hello 

i  have  this  simple  code  it  copies data from sheet to  another  but  the  problem  when i  add a new  data  it  delete old  data  i  would  copy data   under old  data  and  highlight  the  copied data  in source data( sheet1)  and  if  i  repeat  the  data is  already existed  then ignore them  and  give me message"this data are duplicated 

Sub CopyStuff()
Dim x As Range
Dim y As Range
Set x = Application.InputBox("Select what copy using the mouse", Type:=8)
x.Interior.ColorIndex = vbRed
Set y = ActiveWorkbook.Sheets("Sheet2").Range("A1")
x.Copy y

End Sub
Answer
Discuss

Answers

0
Selected Answer

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
Discuss

Discussion

i don't  tought the code will complicated like this   you  did great  work  the  code  works  as  what  i want     but  i  don't  understand  why  it  gives me error when  i  press cancel  inputbox  it  gives me  object  reguired    despite  you put  this  line  [CODEIf Target Is Nothing Then Exit Sub   [/CODE] it gives  me  error  it  should  exit the programm without  error    so  if  is  possible   when  i  don't fill inputbox  press ok    it show message  please  select  the  range  and  if  press cancel   then  exit  inputbox  thanks
leopard (rep: 32) Aug 16, '20 at 5:21 am
Yes. I thought, If Target Is Nothing Then Exit Sub would take care of that. But since it didn't I removed that line and added an error trap in my published code instead. Only the rows from On Error Resume Next to On Error Goto 0 have been changed.
Variatus (rep: 4208) Aug 16, '20 at 8:19 pm
thanks  vaiatus   that's better 
leopard (rep: 32) Aug 17, '20 at 1:38 pm
Add to Discussion


Answer the Question

You must create an account to use the forum. Create an Account or Login