Checking date for two columns

[cadlum]

I have two excel 2010 files that I want to run this on. Each one has about 10+ worksheets in them. I am looking to have a vba script that will look at columns D and E starting at row 4 and check if they are expiring in the next month or have already expired (before today's date). Then it would return a text file that will say which worksheet it is on, the row and column, and what date is in that cell.

I have looked around a bit and cant find much. I am also quite new to vba scripting. So if you could do me a big favor and explain the code a bit, I would be quite grateful. I have a programming background, just not in vba.

thanks in advance

 

[JLGWhiz]

This procedure assumes that columns D and E of each worksheet in both workbooks contains dates, formatted as Date type and that both columns represent expiration dates. (Why two columns for one criteria?). It also assumes that both workbooks will be open when the code is run, hosted by a third workbook, in which a new sheet will be added to record any items found that meet the criteria. This will create a separate file named Expirations which you can save as a txt file if you wish.

Sub ckDt()
Dim wb2 As Workbook, wb3 As Workbook, sh As Worksheet, rng As Range, NewSh As Worksheet, c As Range, lr As Long, i As Long
Set wb2 = Workbooks(2) 'Edit workbook name
Set wb3 = Workbooks(3) 'Edit workbook name
Set NewSh = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
NewSh.Name = "Expirations"
    With NewSh
        .Range("A1") = "WB Name"
        .Range("B1") = "Sheet Name"
        .Range("C1") = "Address"
        .Range("D1") = "Exp Date"
    End With
wb = Array(wb2, wb3)
For i = LBound(wb) To UBound(wb)
    For Each sh In wb(i).Sheets
        If Application.CountA(sh.Range("D:E")) > 0 Then 'Insurance to avoid error message
        lr = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, _
            SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
        Set rng = sh.Range("D4:E" & lr)
        expMo = Month(Date) + 1
        For Each c In rng
            If c <> "" And IsDate(c.Value) Then
                If c.Value <= Date Or Month(c.Value) = expMo Then
                    With ThisWorkbook.Sheets("Expirations")
                        rw = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                        .Cells(rw, 1) = wb(i).Name
                        .Cells(rw, 2) = sh.Name
                        .Cells(rw, 3) = c.Address
                        .Cells(rw, 4) = c.Value
                    End With
                End If
            End If
        Next
        End If
    Next
Next
ThisWorkbook.Sheets("Expirations").Copy
ActiveWorkbook.SaveAs "Expirations " & Format(Date, "mmm-yyyy") & ".xlsx"
ThisWorkbook.Sheets("Expirations").Delete
End Sub

 

[cadlum]

Wow, that looks perfect. I will start fiddling with it now and see how it works out. I am doing this for warranty expiration and lease expiration of a list of laptops. Thanks for the quick response!

 

[JLGWhiz]

Wow, that looks perfect. I will start fiddling with it now and see how it works out. I am doing this for warranty expiration and lease expiration of a list of laptops. Thanks for the quick response!

You're welcome.
regards, JLG

 

[cadlum]

I was working on the code and I got an 'type mismatch' on line: If c <> "" And IsDate(c.Value) Then

The only other edits I made to the code were to change the workbook names to reflect the ones I have to use.

 

[JLGWhiz]

I was working on the code and I got an 'type mismatch' on line: If c <> "" And IsDate(c.Value) Then

The only other edits I made to the code were to change the workbook names to reflect the ones I have to use.

Hi cadlum,
Try this:
Change If c <> "" To If c <> Empty
Also, to avoid a pop up when the added sheet is deleted from your host workbook, modify the last line of the code as shown below:

Application.DisplayAlerts = False
ThisWorkbook.Sheets("Expirations").Delete
Application.DisplayAlerts = True

If it still does not work properly then do this for me.
1. Run the code and let it error.
2. Click the debug button on the error message box.
3. While in debug mode, hover the mouse pointer over sh.Name and c.Address and then tell me what is in that location. You might also have to see which workbook it is in with the wb(i) variable.
4. Also, post the code as you currently have it.
Since that line is only checking that there is a value there and that the data type is "Date", the only thing that would cause it to hiccup would be if the value of variable c. Since it is a range object variable, the value equates to Empty for a blank cell, rather than "".

 

[JLGWhiz]

That change for the If statement would probably work better as:

If Not IsEmpty(c) And IsDate(c.Value) Then

 

[cadlum]

The last if statement you gave was the fix. Thanks so much for the help!

 

[JLGWhiz]

The last if statement you gave was the fix. Thanks so much for the help!

You're welcome
Regards, JLG

 

[cadlum]

A quick update... When running the code I was getting dates that were years in the future (ex. 5/1/2015). This wasnt a big deal as I could edit the results afterwards. now that I have had a chance to learn some VBA and play with the code a bit, I figured out why that was happening.

Originally, your code had this line:

If c.Value <= Date Or Month(c.Value) = expMo Then

The problem with that was that the second have of the statement (after the OR), looked only at the month part of the date. So any months found that were a 4 or 5 (since its april now), were being tagged and added to the results.

To fix this, I came up with this code:

For i = LBound(wb) To UBound(wb)
    For Each sh In wb(i).Sheets
        If Application.CountA(sh.Range("D:E")) > 0 Then 'Insurance to avoid error message
            lr = sh.Cells.Find(What:="*", After:=sh.Range("A1"), LookAt:=xlPart, LookIn:=xlFormulas, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row
            Set rng = sh.Range("D4:E" & lr)
            expMo = DateAdd("m", 1, Date)
            For Each c In rng
                If Not IsEmpty(c) And IsDate(c.Value) Then
                    If c.Value <= expMo Then
                        With ThisWorkbook.Sheets("Expirations")
                            rw = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                            .Cells(rw, 1) = wb(i).Name
                            .Cells(rw, 2) = sh.Name
                            .Cells(rw, 3) = c.Address(False, False)
                            .Cells(rw, 4) = c.Value
                            .Cells(rw, 5) = sh.Range("J" & c.Row)
                        End With
                    End If
                End If
            Next
        End If
    Next
Next

Hope this helps any future visitors!