Row Transfer Macro

wknight7

New Member
Joined
Mar 1, 2023
Messages
12
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
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.
 

Attachments

  • current log.png
    current log.png
    69.3 KB · Views: 27
  • overdue log.png
    overdue log.png
    25.1 KB · Views: 20

Excel Facts

Convert text numbers to real numbers
Select a column containing text numbers. Press Alt+D E F to quickly convert text to numbers. Faster than "Convert to Number"
Try:
VBA Code:
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
 
Upvote 0
Thanks so much for taking a look, much appreciated.

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

Attachments

  • debug.png
    debug.png
    29.6 KB · Views: 22
  • runtime error.png
    runtime error.png
    6.4 KB · Views: 10
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
Try this version. I've also added a warning message in case there are no dates before today in column F.
VBA Code:
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
 
Upvote 1
Solution
Try this version. I've also added a warning message in case there are no dates before today in column F.
VBA Code:
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.
 
Upvote 0
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?
 
Upvote 0
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!!
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top