VBA Macro to Copy Row Based on Date Criteria

Wolfgang5884

New Member
Joined
Nov 3, 2015
Messages
5
Greetings MrExcel forum members. I'm a beginner when it comes to writing macros and have used this source before, but I'm having trouble with a new macro. Any help this amazing community can provide will be greatly appreciated.

My boss wants a monthly report listing all personnel that are going to have annual training due in that current month. For example, December's report had all people with a "Last Complete" date of any day in December of 2014. Bob would be in the report, but Joe and Dan would not. I threw together some VBA, but it does not work. Can you please tell me what I'm doing wrong?

Below is an example of the spreadsheet and the VBA code:

ABCDEFGHIJK
1OfficeNameJob PositionBuldingID #E-MailStartDoneLast CompleteLast ArchivedPercent Complete
2BobYesYes12/29/2014Not Archived
3JoeYesYes12/6/201512/1/2014
DanYesYes11/4/201411/15/2013

<tbody>
</tbody>


Sub This_Month()


Sheet1.Activate


Dim lr As Long, lr2 As Long, r As Long
lr = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
For r = lr To 2 Step -1
If Range("I" & r).Value = "=Month(Now()),Year(Now()-1)" Then
Rows(r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)
lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
End If
Next r




End Sub
 

Excel Facts

Shade all formula cells
To shade all formula cells: Home, Find & Select, Formulas to select all formulas. Then apply a light fill color.
Try this line instead

Code:
If Month(Range("I" & r).Value) = Month(Now()) And Year(Range("I" & r).Value) = Year(Now()) - 1 Then
 
Upvote 0
Excellent! I think it worked; however, I now get the following error:

"Run-time error 1004

We can't paste because the Copy area and paste area aren't the same size.

Try one of the following:
Click one cell, then paste.
Select a rectangle that's the same size, then paste."


When I debug, the following code is highlighted:
Rows(r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)
 
Upvote 0
Try

Code:
Range("A" & r & ":K" & r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)
 
Upvote 0
Thanks for helping, but now I get the following error:

"Run-time error '13':

Type mismatch"

Entire Code:
Dim lr As Long, lr2 As Long, r As Long
lr = ActiveSheet.Cells(Rows.Count, "I").End(xlUp).Row
lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
For r = lr To 2 Step -1
If Month(Range("I" & r).Value) = Month(Now()) And Year(Range("I" & r).Value) = Year(Now()) - 1 Then
Range("A" & r & ":K" & r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)
lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
End If
Next r

Highlighted Portion in debug:
If Month(Range("I" & r).Value) = Month(Now()) And Year(Range("I" & r).Value) = Year(Now()) - 1 Then
Range("A" & r & ":K" & r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)
 
Upvote 0
It's working here ok, is column I the right one to be determining the last row in both worksheets?
You're not specifying the data sheet anywhere, maybe thats the problem?

Code:
Dim lr As Long, lr2 As Long, r As Long
Dim dataSheet As Worksheet
Set dataSheet = Worksheets("Sheet1")
With dataSheet
    lr = .Cells(Rows.Count, "I").End(xlUp).Row
    lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
    For r = lr To 2 Step -1
        If Month(.Range("I" & r).Value) = Month(Now()) And Year(.Range("I" & r).Value) = Year(Now()) - 1 Then
            .Range("A" & r & ":K" & r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)
            lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
        End If
    Next r
End With

Replace Sheet1 with your sheet name
 
Upvote 0
I found the issue. When an individual starts the training and does not finish, the cell in "I" will contain "Incomplete". I ran the below code without the "Incomplete" cells and it worked. Is there something I can add to the code to skip cells that do not have a date in column "I"?

Code:
Dim lr As Long, lr2 As Long, r As Long
lr = Sheet1.Cells(Rows.Count, "I").End(xlUp).Row
lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
For r = lr To 2 Step -1
If Month(Range("I" & r).Value) = Month(Now()) And Year(Range("I" & r).Value) = Year(Now()) - 1 Then
Range("A" & r & ":K" & r).Copy Destination:=Sheets("This Month").Range("A" & lr2 + 1)
lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
End If
Next r
 
Upvote 0
Code:
Dim lr As Long, lr2 As Long, r As Long
Dim dataSheet As Worksheet
Set dataSheet = Worksheets("Sheet1")
With dataSheet
    lr = .Cells(Rows.Count, "I").End(xlUp).Row
    lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
    For r = lr To 2 Step -1
        If IsDate(.Range("I" & r).Value) Then
            If Month(.Range("I" & r).Value) = Month(Now()) And Year(.Range("I" & r).Value) = Year(Now()) - 1 Then
                .Range("A" & r & ":K" & r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)
                lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
            End If
        End If
    Next r
End With
 
Upvote 0
Worked perfectly! Thank you very much. You have saved me a lot of time with this.

Code:
Dim lr As Long, lr2 As Long, r As Long
Dim dataSheet As Worksheet
Set dataSheet = Worksheets("Sheet1")
With dataSheet
    lr = .Cells(Rows.Count, "I").End(xlUp).Row
    lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
    For r = lr To 2 Step -1
        If IsDate(.Range("I" & r).Value) Then
            If Month(.Range("I" & r).Value) = Month(Now()) And Year(.Range("I" & r).Value) = Year(Now()) - 1 Then
                .Range("A" & r & ":K" & r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)
                lr2 = Sheets("This Month").Cells(Rows.Count, "I").End(xlUp).Row
            End If
        End If
    Next r
End With
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,256
Members
448,557
Latest member
richa mishra

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