VBA code not pasting data correctly, keeps overwriting data in target sheet

[handoverhammer]

Hi Excel Wizards,

The function of this code is to copy data from one sheet to another using a drop down and message box, also adding a timestamp. Unfortunately the destination is targeting row 2, not the last blank row, and overwriting any data in row 2 of the destination sheet when the copy is triggered in the drop down.

FYI: drop down is in "H", the rows being copied are A:I, time stamp is in "F"

Here's what I have right now:

Private Sub Worksheet_Change(ByVal Target As Range)If Not Intersect(Target, Range("H:H")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim Lastrow As Long
Dim ans As String
ans = Target.Value
Dim Response As VbMsgBoxResult
If ans = "Initial" Then
Response = MsgBox("Move to Sandbox?", vbQuestion + vbYesNo)
End If
If Response = vbNo Then Exit Sub
If ans = "Initial" Then
Lastrow = Sheets("Sandbox").Cells(Rows.Count, "I").End(xlUp).Row + 1
Cells(Target.Row, "F").Value = Now
Rows((Target.Row)).Copy Destination:=Sheets("Sandbox").Rows(Lastrow): Rows(Target.Row).Delete
Sheets("Sandbox").Select
End If

'

Please advise.

Thank you!

 

[handoverhammer]

Of course. Thanks again!

Let's say the dates in Column G are:
4/30/2018
4/25/2018
4/28/2018
4/26/2018
4/29/2018
4/27/2018
4/24/2018
4/23/2018

Ideally, I want to sort the rows by these dates in Column G, beginning with any date equal to and after "today" (upcoming nearest due date) in ascending order so the earlier values precede the later ones. I don't care what happens to rows/dates before today.

The new sort would look like this, based from today 4/25:
4/25/2018
4/26/2018
4/27/2018
4/28/2018
4/29/2018
4/30/2018
4/24/2018
4/23/2018

 

[mumps]

Would it be OK to delete the rows with the dates before today?

 

[handoverhammer]

Hmm ... probably not OK to delete them, just in case they are overdue.

How about we remove the condition of "today", and just add a straightforward ascending sort for now? I can revisit adding additional conditions later.

 

[handoverhammer]

I did find this thread: https://www.mrexcel.com/forum/excel-questions/974337-automatically-sort-date.html

From there I drafted this:

Dim Lastrow As Long    
Lastrow = Cells(Rows.Count, "A").End(xlUp).Row
If Not Intersect(Target, Range("H2:H" & Lastrow)) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Range("A2:I" & Lastrow).Sort Key1:=Target.Offset(0, -1)
End If

Not sure about the rows.count in line 2 but could something like this work?

 

[mumps]

Try this macro in the code module for ThisWorkbook. The macro assumes that all sheets have headers in row 1.

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    If Intersect(Target, Range("H:H")) Is Nothing Or Target.Cells.Count > 1 Then Exit Sub
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim LastRow As Long
    On Error GoTo errhandler
    If MsgBox("Move row " & Target.Row & " to " & Target & "?", vbQuestion + vbYesNo) = vbNo Then
        Exit Sub
    Else
        Cells(Target.Row, "F").Value = Now
        Target.EntireRow.Copy Sheets(Target.Value).Cells(Sheets(Target.Value).Rows.Count, "A").End(xlUp).Offset(1, 0)
    End If
    Sheets(Target.Value).Select
    Target.EntireRow.Delete
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range("G2:G" & LastRow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range("G1:G" & LastRow)
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("G1:G" & LastRow).AutoFilter Field:=1, Criteria1:="<" & Date
    Range("G2:G" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Cut Range("A" & LastRow + 1)
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
errhandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

 

[handoverhammer]

Sorry Mumps, that macro does not work. Nothing triggers now following a drop down selection.

Yes, there are headers in Row1.

 

[handoverhammer]

My apologies, I needed to save, exit and reopen. This kinda works.

It is sorting, however, now once the data is moved to a new row, that row's height becomes zero or possibly the row becomes "hidden". You can see the sheet and all the unaffected rows, but any sorted rows are no longer visible.

 

[mumps]

I am testing the macro on dummy sheets and data and it is working properly. It may not work properly on your data even if there is a small difference in how the data is organized. The only sure way to get it right is to test it on your actual file. Perhaps you could upload a copy of your file to a free site such as www.box.com. or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. If the workbook contains confidential information, you could replace it with generic data.

 

[handoverhammer]

I found the problem.

The new macro is creating a filter in G that is affecting the view.

Here:

[COLOR=#333333]Range("G1:G" & LastRow).AutoFilter Field:=1, Criteria1:="<" & Date
[/COLOR]

I removed that line of code and it works now!

 

[mumps]

I don't see how removing that line of code helps. It was designed to separate the dates that are before 'today'. Please double check to make sure that the end result is accurate and what you want. If you can upload a copy of the file as I suggested in Post #18 , I could have a look.