Row Transfer Macro

[wknight7]

Hello-
I'm trying to create a macro to copy a row (columns A-F) from worksheet "Current Log" if the date in column F (Due Date) is before today, and paste that to another sheet "Overdue Log" in the same workbook in columns B-G. In column A of "Overdue Log" I need to add today's date.

I've attached a screenshot of sample data for the "current log" and "overdue log." So what I would want is to copy rows 2 - 9 on the "current log" sheet, columns A - F only, and paste them beginning at B8 on the "overdue log" and adding today's date into column A. The "current log" updates every day, so the pasting into the "overdue log" would need to start at first unused row each time.

I've found several examples of somewhat similar scenarios across the web, but I have not been able to piece them together into anything that comes even close, so hoping for some help from those of you that can knock this out in your sleep... thanks so much.

 

[mumps]

Try:

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, lRow As Long, lRow2 As Long
    Set srcWS = Sheets("Current Log")
    Set desWS = Sheets("Overdue Log")
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1:F" & lRow).AutoFilter Field:=4, Criteria1:="<" & Date
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1)
        .Range("A1").AutoFilter
    End With
    lRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    desWS.Range("A" & lRow2 + 1).Resize(lRow - lRow2) = Date
    Application.ScreenUpdating = True
End Sub

 

[wknight7]

Thanks so much for taking a look, much appreciated.

I'm getting a run time error. I've attached screen shots.

 

[mumps]

I tested the macro on some dummy data and it worked properly. It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach screenshots (not pictures) of your two sheets. Alternately, 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.

 

[wknight7]

I had added the code to the non-sample data. On your advice that it was working for you I added it to the sample data file, and same result. Here is dropbox:

Much appreciated.

 

[mumps]

Try this version. I've also added a warning message in case there are no dates before today in column F.

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, lRow As Long, lRow2 As Long
    Set srcWS = Sheets("Current Log")
    Set desWS = Sheets("Overdue Log")
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1:F" & lRow).AutoFilter Field:=6, Criteria1:="<" & Date
        If .[subtotal(103,A:A)] - 1 = 0 Then
            MsgBox ("There are no dates before today.")
            .Range("A1").AutoFilter
            Exit Sub
        End If
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1)
        .Range("A1").AutoFilter
    End With
    lRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    desWS.Range("A" & lRow2 + 1).Resize(lRow - lRow2) = Date
    Application.ScreenUpdating = True
End Sub

 

[wknight7]

Try this version. I've also added a warning message in case there are no dates before today in column F.

Sub CopyRows()
    Application.ScreenUpdating = False
    Dim srcWS As Worksheet, desWS As Worksheet, lRow As Long, lRow2 As Long
    Set srcWS = Sheets("Current Log")
    Set desWS = Sheets("Overdue Log")
    lRow2 = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    With srcWS
        lRow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        .Range("A1:F" & lRow).AutoFilter Field:=6, Criteria1:="<" & Date
        If .[subtotal(103,A:A)] - 1 = 0 Then
            MsgBox ("There are no dates before today.")
            .Range("A1").AutoFilter
            Exit Sub
        End If
        .AutoFilter.Range.Offset(1).Copy desWS.Cells(desWS.Rows.Count, "B").End(xlUp).Offset(1)
        .Range("A1").AutoFilter
    End With
    lRow = desWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    desWS.Range("A" & lRow2 + 1).Resize(lRow - lRow2) = Date
    Application.ScreenUpdating = True
End Sub

Thank you so much- that is working perfectly on the sample sheet. I really appreciate it. For whatever reason nothing happens on my real data sheet at work, aside from a blink I usually see when a macro runs. No error message, nothing. The tabs and columns are all named and arranged as in the sample data sheet. Any advice as to what I can check? At work I absolutely cannot post this sheet to dropbox or even email it out. I tried it added in both personal.xlsb and added as a module for just that workbook with the same result. Macros are enabled. I don't know what else to check.

Regardless, I really appreciate the help with the code.

 

[mumps]

Could you de-sensitize a dozen or so rows in your actual data file by replacing any sensitive information with generic data and upload the de-sensitized version?

 

[wknight7]

Dropbox and all similar services / websites are blocked, thumb drives not recognized... very big brother around here.

However, on work machine I was testing all this on a copy of the actual workbook. I crossed my fingers and tried it on the live workbook and it worked just fine. Don't know why, don't care. So thank you very much!!

 

[mumps]

You are very welcome.