Solved

Find dates in Excel with VB Script

Posted on 2014-03-24
20
458 Views
Last Modified: 2014-04-04
I borrowed this code from someone who was doing something similar to me; Looking at a date column in Excel and if it is a certain date (currently it's set at today's date) then it sets the word YES in the column to the right of it and in the script if the word YES is detected it fires off an email alert.  I would like help modifying this script (I've already tweaked it some) so that it checks this column in Excel for a date that is 4 years after its purchase date.  I have one column that shows the purchase date and the column directly to the right of that shows the purchase date + 4 years, call it the replacement date.  If the replacement date is => 4 years then I want the script to kick off the alert.  What do I need to change?

Dim objExcel 
Dim objOutlook 
Dim objMail 
Dim objWB 
Dim objWS 
Dim vCell 
Dim wsIndex, bodyText 
 
Set objExcel = CreateObject("Excel.Application") 
Set objOutlook = CreateObject("Outlook.Application") 
 
objExcel.DisplayAlerts = False 
objExcel.Workbooks.Open ("C:\ServerInventory.XLSX") 
Set objWB = objExcel.Activeworkbook 
bodyText = "The following servers are nearing their 4 year replacement:" & vbNewLine & vbNewLine 
For wsIndex = 1 To 2 
    Set objWS = objWB.Worksheets(wsIndex) 
    For Each vCell In objWS.Range("K2:K" & objWS.Cells(objWS.Rows.Count, "K").End(-4162).Row).Cells 
        If FormatDateTime(vCell) = FormatDateTime(Date) Then 
            If vCell.Offset(0, 1).Value <> "YES" Then 
                bodyText = bodyText & vCell.offset(0, -3).Value & " - " & vCell.offset(0, -2).Value & vbNewLine 
                vCell.Offset(0, 1).Value = "YES" 
            End If 
        End If 
    Next 
Next 
 
Set objMail = objOutlook.CreateItem(olMailItem) 
objMail.To = "user@domain.com" 
objMail.Subject = "Servers expiring soon" 
objMail.Body = bodyText 
objMail.Send 
 
objWB.Save 
objWB.Close 
objExcel.Quit 
 
Set objExcel = Nothing 
Set objWB = Nothing 
Set objWS = Nothing 
Set objMail = Nothing 
Set objOutlook = Nothing

Open in new window

0
Comment
Question by:Brad Bouchard
  • 11
  • 8
20 Comments
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Hi, assuming column K is your purchase date, and column L is your replacement date (replacing the YES column), then you should just be able to change this:
            If vCell.Offset(0, 1).Value <> "YES" Then

to this
            If DateAdd("yyyy", 4, CDate(FormatDateTime(vCell))) <= CDate(FormatDateTime(vCell.Offset(0, 1).Value)) Then


Regards,

Rob.
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
I will try this and let you know how it works.  Also, I've got a few more updates to share with you that have progressed since I first posted; I'll share those as well.
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Sure, keep me posted.
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
Rob, as I'm not that good at coding/scripting just yet, would you be willing to write me the code needed if I describe what I want the output to be?

Basically I'd like my code, above, tweaked so that it checks a date in Excel and if the date that it finds is 4 years old or older (i.e. the date column will have 4/3/2010) then it shoots off the email.  I've got the email sending part down I think, but I'd like to capture the name of the server which is a few cells offset to the left of it; I can tweak that on my own, but just wondered if you'd be able to do this for me?

Let me know, thanks.
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Sure, I can do that, but it would be much easier if you could provide me a sample of your worksheet so that I can see which columns you need to refer to.  Then I can tweak and test it.  You can change the data a bit if you need to.

Regards,

Rob.
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
Sounds good, I'll get a sample copy for you and you've already got my code up above.  Give me a few minutes to upload it.
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
Ok, I've attached a sample spreadsheet.  It's got only 1 row, but that should be enough.  I'd like to trigger this email alert either based on Column J, or Column K; probably J though as it would make more sense.  What I'd like to do is see if Column J is either 4 years from today's date or more than 4 years than today's date, and if either of those conditions is met, have it fire off the email which I've already got down in the code.

The only other thing I should mention is that I want the script to put Column B in the email as part of the body as well as Column K; something like "Server 'servername from column' has reached it's end of life, which was 'end of life from Excel'"

ServerInventory.xlsx
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Sure, I'll have a look....all sounds doable....
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Hmmm...I notice you have the date formats different in columns J and K, due to the fact that the column K format is system regional settings.  Me being in Australia, column K is d/m/yyyy.   That's OK though. I'll base the calculation from column J on the fact that you have the custom format of m/d/yy

Rob.
0
How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
Whatever format you need to change it to is completely fine with me... the end result is more important.  Also, I forgot to mention that there will be multiple tabs in the spreadsheet and wondered if that would cause a problem for the code to check multiple tabs?
0
 
LVL 65

Accepted Solution

by:
RobSampson earned 500 total points
Comment Utility
OK, try this.  I changed a couple of things while I was at it.

Dim objExcel
Dim objOutlook
Dim objMail
Dim objWB
Dim objWS
Dim vCell
Dim wsIndex, bodyText, blnServersFound, arrDateParts, dtePurchaseDate

Const xlUp = -4162
 
Set objExcel = CreateObject("Excel.Application")
 
objExcel.DisplayAlerts = False
objExcel.Visible = True
objExcel.Workbooks.Open ("C:\ServerInventory.XLSX")
Set objWB = objExcel.ActiveWorkbook
bodyText = "The following servers are nearing their 4 year replacement:" & vbNewLine & vbNewLine
blnServersFound = False
For wsIndex = 1 To objWB.Sheets.Count
    Set objWS = objWB.Worksheets(wsIndex)
    For Each vCell In objWS.Range("J2:J" & objWS.Cells(objWS.Rows.Count, "J").End(xlUp).Row).Cells
       	arrDateParts = Split(vCell, "/")
       	If UBound(arrDateParts) = 2 Then
            dtePurchaseDate = FormatDateTime(arrDateParts(1) & "/" & MonthName(arrDateParts(0), True) & "/" & arrDateParts(2))
			If Date >= DateAdd("yyyy", 4, FormatDateTime(dtePurchaseDate)) Then
				bodyText = bodyText & "Server " & objWS.Cells(vCell.Row, "B").Value & " (" & objWS.Cells(vCell.Row, "G").Value & " - " &_
					objWS.Cells(vCell.Row, "H").Value & ") has reached its end of life, which was " & dtePurchaseDate & vbNewLine
				blnServersFound = True
			End If
		End If
    Next
Next

If blnServersFound = True Then
	Set objOutlook = CreateObject("Outlook.Application")
	Set objMail = objOutlook.CreateItem(olMailItem)
	objMail.To = "user@domain.com"
	objMail.Subject = "Servers expiring soon"
	objMail.Body = bodyText
	objMail.Send
	Set objMail = Nothing
	Set objOutlook = Nothing
End If
 
objWB.Save
objWB.Close
objExcel.Quit
 
Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing

Open in new window


It should work for multiple tabs with the same data and format structure.  I changed it to look on every sheet using objWB.Sheets.Count
I also added objExcel.Visible = True, which you can change to False if you don't want to see Excel.
I changed the body text around a bit so it now says
Server SVR1 (DL360 G7 - Hyper-V Host) has reached its end of life, which was 4/01/2009
I added a blnServersFound flag so it only sends the email if an expired server was found.

See how it goes.

Regards,

Rob.
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
You sir, are awesome.  I'm sure it took you a matter of seconds to do what I asked, but it works on my end and is simply awesome.  You made my day, heck my week at work with this; but you know what they say, it's the little things.

I appreciate this very much.  Hopefully I can return the favor sometime soon.
0
 
LVL 17

Author Closing Comment

by:Brad Bouchard
Comment Utility
Couldn't have asked for a better script from Rob.
0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Great.  No problem.  It's just practice really....I've been scripting automation things like this for nearly 10 years, but I still have to look some things up every now and then ;-)

If you need help understanding anything (except nuclear physics) let me know.

Thanks for the grade.

Regards,

Rob.
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
If you need help understanding anything (except nuclear physics) let me know.

Well, there is one thing.  I've looked this up many times before and I always see many different answers, but I'd love to start doing more scripting/developing/programming as I've typically always been on the Sys Admin side of things.  I get scripting and the logic most of the time behind it, it's just knowing the syntax and what things to use to do what I want.

All that to say, what would you recommend for a guy like myself to start getting proficient in VB, VBS, .NET, etc?

Thanks in advance.
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
Also, I'm sorry to bug you again Rob, and if I need to post a separate question I will, but I did some testing on this with my server and if Outlook isn't open I receive an error.  The problem is, I can't leave Outlook open on the server all the time.  I do however have an SMTP server I can send through.  Do you know how to edit this to make it send to the SMTP server so it can bypass Outlook?  

If you don't, how can I add a few lines of code to make the script open Outlook first, then send, then close Outlook?  Also, Outlook gets a pop up asking if I want to Allow or Deny sending of the email, do you know how to turn this off?
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
If you don't, how can I add a few lines of code to make the script open Outlook first, then send, then close Outlook?  Also, Outlook gets a pop up asking if I want to Allow or Deny sending of the email, do you know how to turn this off?

At this point the Outlook option is out so I will have to do the SMTP thing.  Let me know, thanks.
0
 
LVL 17

Author Comment

by:Brad Bouchard
Comment Utility
Ok, I know I have given you about a million replies, but here was a script that I found that worked, so now I'm just wondering how to implement/merge it into my current script.

strMessage = "SERVERS EXPIRING YOU IDIOT"
strTo= "user"
strFrom="user"
strSubject="test"
strAccountID="user"
strPassword="password"
strSMTPServer="smtp.server.com"
SendMail strTo,strFrom,strSubject,strMessage,strAccountID,strPassword,strSMTPServer


' send email using public mail servers
Function SendMail( strFrom, strSendTo, strSubject, strMessage , strUser, strPassword, strSMTP )

	Set oEmail = CreateObject("CDO.Message")
	
	'configure message
	With oEmail.Configuration.Fields
          .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 
          .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTP
          .item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'basic
          .item("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUser
          .item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPassword
          .Update
	End With
	
	' build message
	With oEmail
	     .From = strFrom
	     .To = strSendTo 
	     .Subject = strSubject
	     .TextBody = strMessage
	End With
	
	' send message
	On Error Resume Next
	oEmail.Send
	If Err Then
	     WScript.Echo "SendMail Failed:" & Err.Description
	End If
		
End Function

Open in new window

0
 
LVL 65

Expert Comment

by:RobSampson
Comment Utility
Hi, sorry for my delay.  I was asleep at the time you replied, and you're probably asleep now, but here is my code that I use to send emails through an SMTP server, that I have added to your other code.  You can see I've just replaced the Outlook mail stuff with a call to the SendEmail procedure.

Regards,

Rob.

Dim objExcel
Dim objOutlook
Dim objMail
Dim objWB
Dim objWS
Dim vCell
Dim wsIndex, bodyText, blnServersFound, arrDateParts, dtePurchaseDate
Dim strServer, strTo, strFrom, strSubject

strServer = "mailhost.abc.com"
strTo = "user@domain.com"
strFrom = "john.doe@abc.com"
strSubject = "Servers expiring soon"

Const xlUp = -4162
 
Set objExcel = CreateObject("Excel.Application")
 
objExcel.DisplayAlerts = False
objExcel.Visible = True
objExcel.Workbooks.Open ("C:\ServerInventory.XLSX")
Set objWB = objExcel.ActiveWorkbook
bodyText = "The following servers are nearing their 4 year replacement:" & vbNewLine & vbNewLine
blnServersFound = False
For wsIndex = 1 To objWB.Sheets.Count
    Set objWS = objWB.Worksheets(wsIndex)
    For Each vCell In objWS.Range("J2:J" & objWS.Cells(objWS.Rows.Count, "J").End(xlUp).Row).Cells
       	arrDateParts = Split(vCell, "/")
       	If UBound(arrDateParts) = 2 Then
            dtePurchaseDate = FormatDateTime(arrDateParts(1) & "/" & MonthName(arrDateParts(0), True) & "/" & arrDateParts(2))
			If Date >= DateAdd("yyyy", 4, FormatDateTime(dtePurchaseDate)) Then
				bodyText = bodyText & "Server " & objWS.Cells(vCell.Row, "B").Value & " (" & objWS.Cells(vCell.Row, "G").Value & " - " &_
					objWS.Cells(vCell.Row, "H").Value & ") has reached its end of life, which was " & dtePurchaseDate & vbNewLine
				blnServersFound = True
			End If
		End If
    Next
Next

If blnServersFound = True Then
	SendEmail strServer, strTo, strFrom, strSubject, bodyText, ""
End If
 
objWB.Save
objWB.Close
objExcel.Quit
 
Set objExcel = Nothing
Set objWB = Nothing
Set objWS = Nothing

Sub SendEmail(strServer, strTo, strFrom, strSubject, strBody, strAttachment)
        Dim objMessage
        
        Set objMessage = CreateObject("CDO.Message")
        objMessage.To = strTo
        objMessage.From = strFrom
        objMessage.Subject = strSubject
        objMessage.TextBody = strBody
  		If strAttachment <> "" Then objMessage.AddAttachment strAttachment
  		
        '==This section provides the configuration information for the remote SMTP server.
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'Name or IP of Remote SMTP Server
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
        'Server port (typically 25)
        objMessage.Configuration.Fields.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25      
        objMessage.Configuration.Fields.Update
        '==End remote SMTP server configuration section==
 
        objMessage.Send
        Set objMessage = Nothing
End Sub

Open in new window

0

Featured Post

Why You Should Analyze Threat Actor TTPs

After years of analyzing threat actor behavior, it’s become clear that at any given time there are specific tactics, techniques, and procedures (TTPs) that are particularly prevalent. By analyzing and understanding these TTPs, you can dramatically enhance your security program.

Join & Write a Comment

A little background as to how I came to I design this code: Around 5 years ago I designed an add-in that formatted Excel files to a corporate standard, applying different cell colours and font type depending on whether the cells contained inputs,…
Convert between Excel file formats (.XLS, .XLSX, .XLSM) with/without macro option David Miller (dlmille) Intro Over this past Fall, I've had the opportunity to see several similar requests and have developed a couple related solutions associate…
This Micro Tutorial will demonstrate the scrolling table in Microsoft Excel using the INDEX function.
This Micro Tutorial will demonstrate how to create pivot charts out of a data set. I also added a drop-down menu which allows to choose from different categories in the data set and the chart will automatically update.

772 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now