Use today's Date to find a due date that is 30 days out and copy rows to sheet.

[meirbabboon]

I found that someone else had posted the core of this code to do something similar to what I am trying to do. The issue that I am having is that when the spreadsheet opens it does not get the rows that have items that are due. If i run the macro once the sheet is open it does not bring the rows/items that are 30 days out from today's date. Any help would be appreciated. Below the code is listed.

Sub getrenewals()


Dim eqWb As Workbook
Dim sh1 As Worksheet
'Dim due, ID, fac, bldg, div, dept, room
Dim Company, Status, AccountMgr, _
StoreworksOrder, Contract, CustomerPO, _
PN, DevicePN, Quantity, TypeofService, _
ServiceName, ServiceProvider, Distributor, _
StartDate, ExpirationDate, RenewalReminder, _
LastUnitPrice, LastUnitCost, RenewingProcess, Comments


Dim dateDue As Date
Dim rArr As Variant
Dim ws As Worksheet


Set sh1 = ThisWorkbook.Sheets("ServiceContractsDue")
Set eqWb = ActiveWorkbook
'Workbooks.Open ("C:\Users\Weldon\My ShareSync\Storeworks\Sales and Marketing Materials\Service Contracts\Test Renewable Licenses Maintenance and Warranties.xlsm")


'.Open("C:\Code3\Equipment Log.xlsx") ' change this to your equipment sheet path
sh1.Rows("2:" & Rows.Count).ClearContents


wsNums = eqWb.Worksheets.Count


For Each ws In eqWb.Worksheets
ws.Activate
Set Company = Cells.Find("Company")
Set Status = Cells.Find("Status")
Set AccountMgr = Cells.Find("AccountMgr")
Set StoreworksOrder = Cells.Find("StoreworksOrder")
Set Contract = Cells.Find("Contract")
Set CustomerPO = Cells.Find("CustomerPO")
Set PN = Cells.Find("PN")
Set DevicePN = Cells.Find("DevicePN")
Set Quantity = Cells.Find("Quantity")
Set TypeofService = Cells.Find("TypeofService")
Set ServiceName = Cells.Find("ServiceName")
Set ServiceProvider = Cells.Find("ServiceProvider")
Set Distributor = Cells.Find("Distributor")
Set StartDate = Cells.Find("StartDate")
Set ExpirationDate = Cells.Find("ExpirationDate")
Set RenewalReminder = Cells.Find("RenewalReminder")
Set LastUnitPrice = Cells.Find("LastUnitPrice")
Set LastUnitCost = Cells.Find("LastUnitCost")
Set RenewingProcess = Cells.Find("RenewingProcess")
Set Comments = Cells.Find("Comments")
lrEq = Range("O" & Rows.Count).End(xlUp).Row
For i = (ExpirationDate.Row + 1) To lrEq
dateDue = Cells(i, ExpirationDate.Column)
dd = DateDiff("d", Date, dateDue)
If Abs(dd) < 30 Then
' I'm assuming that the cells are all located in a row in the order you mentioned
rArr = Range(Cells(Company.Row + 1, Company.Column), Cells(Comments.Row + 1, Comments.Column))
x = 1
lr = sh1.Range("A" & Rows.Count).End(xlUp).Row
For Each c In rArr
sh1.Cells(lr + 1, x) = c
x = x + 1
Next c
sh1.Cells(lr + 1, x + 1) = dateDue
End If
Next i
Next ws
Application.ScreenUpdating = True
End Sub