VBA Macro to Copy Row Based on Date Criteria

[Wolfgang5884]

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:

[TABLE="width: 500"]
<tbody>[TR]
[TD][/TD]
[TD]A[/TD]
[TD]B[/TD]
[TD]C[/TD]
[TD]D[/TD]
[TD]E[/TD]
[TD]F[/TD]
[TD]G[/TD]
[TD]H[/TD]
[TD]I[/TD]
[TD]J[/TD]
[TD]K[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]Office[/TD]
[TD]Name[/TD]
[TD]Job Position[/TD]
[TD]Bulding[/TD]
[TD]ID #[/TD]
[TD]E-Mail[/TD]
[TD]Start[/TD]
[TD]Done[/TD]
[TD]Last Complete[/TD]
[TD]Last Archived[/TD]
[TD]Percent Complete[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD][/TD]
[TD]Bob[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Yes[/TD]
[TD]Yes[/TD]
[TD]12/29/2014[/TD]
[TD]Not Archived[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD][/TD]
[TD]Joe[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Yes[/TD]
[TD]Yes[/TD]
[TD]12/6/2015[/TD]
[TD]12/1/2014[/TD]
[TD][/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[TD]Dan[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]Yes[/TD]
[TD]Yes[/TD]
[TD]11/4/2014[/TD]
[TD]11/15/2013[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]


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

 

[sericom]

Try this line instead

If Month(Range("I" & r).Value) = Month(Now()) And Year(Range("I" & r).Value) = Year(Now()) - 1 Then

 

[Wolfgang5884]

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)

 

[sericom]

Try

Range("A" & r & ":K" & r).Copy Destination:=Sheets("This Month").Range("I" & lr2 + 1)

 

[Wolfgang5884]

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)

 

[sericom]

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?

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

 

[Wolfgang5884]

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

 

[sericom]

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

 

[Wolfgang5884]

Worked perfectly! Thank you very much. You have saved me a lot of time with this.

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