I have an excel vba sub that sends email reminders every 14 days based on a date in a cell. I would also like to include the week number since the date in the cell to todays date. E.g. Cell date 1st April to present day 28th April to return 4 weeks. Please can someone help.
Sub SalesProgress14()
'
' 14 Day Sales Chase Loop
'
'Dim Answer As VbMsgBoxResult
'Answer = MsgBox("Are you sure you want to run?", vbYesNo, "Run Macro")
'If Answer = vbYes Then
Dim i As Integer, Mail_Object, Email_Subject, o As Variant, lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
Dim saledate As String
Set Mail_Object = CreateObject("Outlook.Application")
For i = 2 To lr
With Mail_Object.CreateItem(o)
.Subject = "Sales Chase" & Range("S" & i).Value & " " & Range("U" & i).Value & " " & Range("G" & i).Value
.To = "test#test.com"
.Body = Range("S" & i).Value & " " & Range("U" & i).Value & " " & Range("G" & i).Value
'.display
' Our data below
saledate = Range("F" & i).Value
' Send logic
If DateDiff("d", saledate, Date) Mod 14 = 0 Then .Send
If saledate = Date - 7 Then .Send
End With
Next i
'MsgBox "E-mails successfully sent", 64
'Application.DisplayAlerts = False
Set Mail_Object = Nothing
' The End If below relates to the run yes or no box
'End If
End Sub
use
DateDiff("w", saledate, Date)
You could use ISOWEEKNUM
Public Sub Test()
Dim saleDate As Date, currDate As Date
saleDate = "2018-04-01"
currDate = "2018-04-28"
Debug.Print Application.WorksheetFunction.IsoWeekNum(currDate) - Application.WorksheetFunction.IsoWeekNum(saleDate)
End Sub
Related
I have the following code as part of a Job site labor form, which links a full labor call on the "LocLabor" sheet to various single day sign in sheets. This particular code is to add a complete day to the form, and works great, with the exception of these two lines at the bottom:
.Buttons(bnum).ShapeRange.AlternativeText = dayint + 1
.Buttons(bnum + 1).ShapeRange.AlternativeText = dayint + 1
The "scopy", "ecopy", and "brow" variables are used to work out the appropriate lines to copy and paste to the next day. The buttons that are being altered are the newly pasted buttons that were copied within the scopy/ecopy range and are used to add or delete a line from the table they refer to. I need to be able to change the AltText because I am using that as a reference for which day of the labor call they apply to. The "numdays" variable pulls from locsht.Range("L3").Value, which is set to the current number of days on the form prior to running the macro. So it would have a value of 2 when I see the error
Now to the issue - if I have two days existing in the document and I execute the below code, the name of the button changes, but the Alternative Text does not (it remains as "2" or whatever it was prior to copying). Days 4 and up work perfectly though, it is just the transition from day 2 to 3 that I cannot get to work! It also works if I switch out "dayint + 1" to a string, like "banana" for example, but that obviously doesn't help me.
Any ideas would be appreciated.
Option Explicit
Sub add_day()
Dim numdays As String
Dim tbl As TableStyle
Dim newsht As Worksheet
Dim locsht As Worksheet
Dim scopy As Integer
Dim ecopy As Integer
Dim brow As Integer
Dim dayint As Integer
Dim bnum As Integer
Dim tblstart As String
Application.ScreenUpdating = False
'unlock sheet
Worksheets("LocLabor").Unprotect Password:=SuperSecretPW
'set/get variables
Set locsht = Worksheets("LocLabor")
numdays = locsht.Range("L3").Value
dayint = numdays
Worksheets("Labor Sign In Day " & numdays).Copy Before:=Sheets(numdays + 4)
Worksheets("Labor Sign In Day " & numdays & " (2)").Name = "Labor Sign In Day " & numdays + 1
'update number of days on sheet
locsht.Range("L3") = locsht.Range("L3").Value + 1
'rename new sign in sheet
Set newsht = Worksheets("Labor Sign In Day " & numdays + 1)
newsht.Unprotect Password:=SuperSecretPW
'figure out which rows to copy on main sheet
scopy = locsht.ListObjects(dayint).Range.Rows(1).Row - 1
brow = locsht.ListObjects(dayint).Range.Rows.Count
ecopy = scopy + brow
'Copy/paste new day on LocLabor
locsht.Activate
locsht.Rows(scopy & ":" & ecopy).Copy
locsht.Rows(ecopy + 2).Insert Shift:=xlDown
locsht.ListObjects("Tableday" & numdays).Resize Range("A" & scopy + 1 & ":" & "H" & ecopy)
locsht.Range("A" & ecopy + 2 & ":" & "H" & ecopy + 2) = "=IFERROR($A$17+" & numdays & "," & """Enter Load in Date at Top"")"
locsht.Rows(ecopy + 1).EntireRow.Delete
locsht.PageSetup.PrintArea = "$A$1:$H$" & ecopy + (ecopy - scopy + 1)
locsht.HPageBreaks.Add Before:=locsht.Rows(ecopy + 1)
locsht.ListObjects(dayint + 1).Name = "Tableday" & numdays + 1
bnum = (dayint * 2) + 3
tblstart = locsht.ListObjects(dayint + 1).Range.Rows(1).Row + 1
'Enter correct formulas into sign in sheet
With newsht
.ListObjects(1).Name = "signinday" & numdays + 1
.Range("i12") = Left(newsht.Range("i12").Formula, 28) & numdays & Right(newsht.Range("i12").Formula, 48)
.Range("A17") = "=IF(ISBLANK(LocLabor!G" & tblstart & ")=FALSE,LocLabor!G" & tblstart & "&"" ""&LocLabor!F" _
& tblstart & ",IF(ISBLANK(LocLabor!D" & tblstart & ")=TRUE," & """""" & ",LocLabor!D" & tblstart & "))"
.Range("B17") = "=IF(ISBLANK(LocLabor!B" & tblstart & ")=TRUE, """", LocLabor!B" & tblstart & ")"
.Range("G17") = "=IF(ISBLANK(LocLabor!C" & tblstart & ")=TRUE, """", LocLabor!C" & tblstart & ")"
End With
'rename pasted buttons, update alttext
With locsht
.Buttons(bnum).Name = "Button " & bnum
.Buttons(bnum + 1).Name = "Button " & bnum + 1
.Buttons(bnum).ShapeRange.AlternativeText = dayint + 1
.Buttons(bnum + 1).ShapeRange.AlternativeText = dayint + 1
End With
'lock down sheets
Worksheets("LocLabor").Protect Password:=SuperSecretPW, DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
Worksheets("LocLabor").EnableSelection = xlUnlockedCells
Worksheets("Labor Sign In Day " & numdays + 1).Protect Password:=SuperSecretPW, DrawingObjects:=False, Contents:=True, Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingRows:=True, _
AllowInsertingRows:=True, AllowDeletingRows:=True, AllowSorting:=True, _
AllowFiltering:=True
Worksheets("Labor Sign In Day " & numdays + 1).EnableSelection = xlUnlockedCells
ActiveSheet.Buttons(Application.Caller).TopLeftCell.Offset(3, 0).Select
Application.ScreenUpdating = True
End Sub
How do I send email reminders 2 weeks prior to the Lead Date?
Below is my SQL code from a query.
SELECT CalibrationRecord.RecordID, CalibrationRecord.CalRequirement, CalibrationRecord.CalStatus,
CalibrationRecord.CalLocation, Equipment.EquipmentType, Equipment.SerialNo, Equipment.ModelNo,
Equipment.AssetNo, CalibrationRecord.EmpName, Employees.EmailAddress, CalibrationRecord.LastCalDate,
CalibrationRecord.CalTimeInterval, CalibrationRecord.UOM,
DateAdd(IIf([CalibrationRecord]![UOM]="days","d",IIf([CalibrationRecord]![UOM]="month","m","yyyy")),
[CalTimeInterval],[LastCalDate]) AS CalUpcomingDate, CalibrationRecord.DateEmailSent,
DateAdd(IIf([Equipment]![UOM]="weeks","ww"),-[LeadInterval],[CalUpcomingDate]) AS LeadDate
FROM Equipment INNER JOIN (Employees INNER JOIN CalibrationRecord ON Employees.EmpID = CalibrationRecord.EmpName)
ON Equipment.ItemID = CalibrationRecord.EquipItemID
WHERE (((CalibrationRecord.CalStatus)="Not Started")
AND ((Employees.EmailAddress) Is Not Null)
AND ((CalibrationRecord.CalTimeInterval) Between 6 And 9)
AND ((CalibrationRecord.UOM) Like "month")
AND ((Employees.EmpName) Not Like "MFGUSER")) OR (((CalibrationRecord.UOM) Like "days"));
This is my Email reminder code. I just want to include a piece of code that will send email reminder 2 weeks prior to the Lead Date.
Function GenerateEmail(MySQL As String)
On Error GoTo Exit_Function:
Dim oOutLook As Outlook.Application
Dim oEmailAddress As MailItem
Dim MyEmpName As String
Dim MyEquip As String
Dim MyModel As String
Dim MyAsset As String
Dim MySerial As String
Dim rs As Recordset
Set rs = CurrentDb.OpenRecordset(MySQL)
If rs.RecordCount > 0 Then
rs.MoveFirst
Do Until rs.EOF
If Not IsNull(rs!EmailAddress) Then
' Only Send Emails if never been sent before - or past 14 days since last one'
If (IsNull(rs!DateEmailSent)) Or DateDiff("d", rs!DateEmailSent, Date) >= 14 Then
If rs!LeadDate - 2 * 7 <= Date Then **This is what i have so far for the 2 weeks prior to Lead Date**
If oOutLook Is Nothing Then
Set oOutLook = New Outlook.Application
End If
Set oEmailAddressItem = oOutLook.CreateItem(olMailItem)
With oEmailAddressItem
'MyEmpName = DLookup("EmpName", "Employees", "[EmpID]= " & rs!EmpName)
MyEquip = rs!EquipmentType
MyModel = rs!ModelNo
MyAsset = rs!AssetNo
MySerial = rs!SerialNo
.To = "dgaskins#eeimfg.com"
.Subject = "Monthly Calibrations"
.Body = "Calibration ID: " & rs!RecordID & vbCr & _
"Location: " & rs!CalLocation & vbCr & _
"Requirement: " & rs!CalRequirement & vbCr & _
"Name: " & MyEquip & vbCr & _
"Serial No.: " & MySerial & vbCr & _
"Model No.: " & MyModel & vbCr & _
"Asset No.: " & MyAsset & vbCr & _
"Upcoming Date: " & rs!CalUpcomingDate & vbCr & vbCr & _
"This email is auto generated. Please Do Not Reply!"
'.Display
.Send
' Make sure to record that reminder was sent '
rs.Edit
rs!DateEmailSent = Date
rs!LeadDate = DateAdd("ww", -2, Now)
rs.Update
End With
' Only do this if this has been set '
Set oEmailAddressItem = Nothing
End If
End If
End If
rs.MoveNext
Loop
' Do this at end '
Set oOutLook = Nothing
Else
End If
rs.Close
Exit_Function:
Exit Function
End Function
Get rid of this If and Matching Endif
If DateDiff("d", Date, rs!LeadDate) Then **This is what i have so far for the 2 weeks prior to Lead Date**
Change this
' Only Send Emails if never been sent before - or past 14 days since last one'
If (IsNull(rs!DateEmailSent)) Or DateDiff("d", rs!DateEmailSent, Date) >= 14 Then
To This
' Only Send Emails if never been sent before
' - or past 14 days since last one
' - or with 14 days of LeadDate
If (IsNull(rs!DateEmailSent)) Or DateDiff("d", rs!DateEmailSent, Date) >= 14 Or DateDiff("d", Date, rs!LeadDate) <= 14 Then
During launching my macro the Excel application is crashed. If I test the macro with an integer the program runs properly (partnumber = 123). If I check with a string the application is crashed. Thus, no error code is visible for me. I assume that there is a type mismatch (but I set Variant for partnumber)
Sub SbIsInCOPexport()
Dim lastRow As Long
Dim i As Long
Dim found As Boolean
Dim partnumber As Variant
i = 1
found = False
partnumber = ActiveCell.Value
Windows("COPexport.xlsx").Activate
lastRow = Sheets(1).Cells.SpecialCells(xlLastCell).Row
Do While i < lastRow + 1
If Cells(i, 6).Value = partnumber Then
found = True
Exit Do
End If
i = i + 1
Loop
If found = True Then
Cells(i, 6).Select
MsgBox ("Searched part number: " & Str(partnumber) & vbNewLine & "Found part number: " _
& ActiveCell.Value & vbNewLine & "Address: " & Cells(i, 6).Address & vbNewLine & vbNewLine & "Test Order: " & _
Cells(i, 2).Value)
Windows("COPexport.xlsx").Activate
Else
MsgBox "Part number is not found in the COP samples!"
Windows("COPexport.xlsx").Activate
End If
End Sub
What can be the root cause?
I don't see any obvious issues, but consider using the .Find method of range object, like so:
Sub SbIsInCOPexport()
Dim partnumber as Variant
Dim rng as Range
Windows("COPexport.xlsx").Activate
partnumber = ActiveCell.Value
Set rng = Columns(6).Find(partnumber) '## Search in column 6 for partnumber
If rng Is Nothing Then
MsgBox "Part number is not found in the COP samples!"
Windows("COPexport.xlsx").Activate
Else
With rng
MsgBox ("Searched part number: " & Str(partnumber) & vbNewLine & _
"Found part number: " & .Value & vbNewLine & _
"Address: " & .Address & vbNewLine & vbNewLine & _
"Test Order: " & .Offset(0,-4).Value) '## Get the value from column 2
End With
End If
End Sub
I am exporting data from one workbook to another workbook to T13:Tlastrow
This data, from column F in my workbook where I run this macro, I want to be put into {nyckel="TEXT HERE";} in column T in the "new" workbook, starting from row 13 (T13).
I am stuck here. So would really appreciate some help/solution. Thanks!
Sub CopyData()
Dim wkbCurrent As Workbook, wkbNew As Workbook
Set wkbCurrent = ActiveWorkbook
Dim valg, c, LastCell As Range
Set valg = Selection
Dim wkbPath, wkbFileName, lastrow As String
Dim LastRowInput As Long
Dim lrow, rwCount, lastrow2, LastRowInput2 As Long
Application.ScreenUpdating = False
' If nothing is selected in column A
If Selection.Columns(1).Column = 1 Then
wkbPath = ActiveWorkbook.Path & "\"
wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")
Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")
'Application.Run ("'C:\Users\niclas.madsen\Desktop\TEST\CIF LISTEN.xlsm'!DelLastRowData")
LastRowInput = Cells(Rows.count, "A").End(xlDown).Row
For Each c In valg.Cells
lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1
lastrow2 = Range("A" & Rows.count).End(xlUp).Row
lastrow3 = Range("T" & Rows.count).End(xlUp).Row
wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
' Standard inputs
wkbNew.Worksheets(1).Range("D13:D" & lastrow2).Value = "Ange referens och period"
wkbNew.Worksheets(1).Range("E13:E" & lastrow2).Value = "99999002"
wkbNew.Worksheets(1).Range("G13:G" & lastrow2).Value = "EA"
wkbNew.Worksheets(1).Range("H13:H" & lastrow2).Value = "2"
wkbNew.Worksheets(1).Range("M13:M" & lastrow2).Value = "SEK"
wkbNew.Worksheets(1).Range("N13:N" & lastrow2).Value = "sv_SE"
wkbNew.Worksheets(1).Range("P13:P" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("Q13:Q" & lastrow2).Value = "TRUE"
wkbNew.Worksheets(1).Range("S13:S" & lastrow2).Value = "Catalog_extensions"
'wkbNew.Worksheets(1).Range("T" & lastrow3).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & lastrow3).Value & ";}"
Next
' Trying to get this to work
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
For i = 0 To LastRowInput2 - 13
wkbNew.Worksheets(1).Range("T" & 13 + i).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & 13 + i).Value & ";}"
Next i
' END HERE
' wkbNew.Close False
' Find the number of rows that is copied over
wkbCurrent.ActiveSheet.Activate
areaCount = Selection.Areas.count
If areaCount <= 1 Then
MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
Else
i = 1
For Each A In Selection.Areas
'MsgBox "Area " & I & " of the selection contains " & _
a.Rows.count & " rows."
i = i + 1
rwCount = rwCount + A.Rows.count
Next A
MsgBox "The selection contains " & rwCount & " suppliers."
' Write it in A10 in CIF LISTEN
wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
End If
wkbNew.Worksheets(1).Activate
Application.ScreenUpdating = True
Else
MsgBox "Please select cell(s) in column A", vbCritical, "Error"
Exit Sub
End If
End Sub
OK Try
wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" & wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & "}"
Instead of your line:
wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
And remove the whole block marked 'Trying to get this to work
If the code is doing the right action but on the wrong cells, then the problem is in the start and end of the For loop. Your For Loop is going from row '13 + i' where i = 0 (so row 13), to row 13 + LastRowInput2 - 13 (so LastRowInput2). This seems right to me, so the problem must be with the value in LastRowInput2.
You need to correct this line:
LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row
So that is gives you the correct last row input in your data. There are several approaches to finding the end of data depending on whether there may be blank cells in the middle and other factors. This may be one option:
LastRowInput2 = wkbNew.Worksheets(1).Range("T65000").End(xlUp).Row
Be sure to step through the code and verify that LastRowInput2 is set to the value you expect and then this should work.
I have written some Excel VBA code to add the filenames, versions, and last modified date/time to a worksheet. The code appears to work fine, except sometimes the time portion of the Last Modified Date for a file will either be exactly 1 hour forward or backward from what I see in an Explorer window.
I have noticed the values that my code returns is the same as the modified date/time shown in a cmd window if I perform a dir command.
For example, if I look up the dbghelp.dll file in the system32 folder:
C:\Windows\System32>dir dbghelp.*
Volume in drive C has no label.
Volume Serial Number is 16E8-4159
Directory of C:\Windows\System32
21/11/2010 04:24 1,087,488 dbghelp.dll
1 File(s) 1,087,488 bytes
0 Dir(s) 60,439,101,440 bytes free
C:\Windows\System32>
But the same file in an Explorer window shows a modified time of 03:24 on 21/11/2010 - 1 hour earlier.
The code I have written is returning the cmd window time, whereas I want the Explorer window time:
Sub GetFileDetails()
Dim path As String
Dim objFSO As Object
Dim objFile As Object
Dim objFolder As Object
Dim loopCount As Integer
Dim pathCheck As Boolean
'Prompt for directory path
path = InputBox(Prompt:="Enter file path", Title:="Enter file path", Default:="")
If (path = "" Or path = vbNullString) Then
MsgBox ("Invalid path - exiting")
Exit Sub
End If
'Required for interacting with filesystem
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(path)
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
Range("B" & loopCount).Value = objFSO.GetFileVersion(objFile)
Range("C" & loopCount).Value = objFile.DateLastModified
'Combine Version and Modified
If Range("B" & loopCount).Value <> "" Then
Range("D" & loopCount).Value = Range("B" & loopCount).Value & ", " & Range("C" & loopCount).Value
Else
Range("D" & loopCount).Value = Range("C" & loopCount).Value
End If
loopCount = loopCount + 1
Next
'Set up headings
Range("A" & 1).Value = (loopCount - 3) & " files found in " & path
Range("A" & 2).Value = "FileName"
Range("B" & 2).Value = "Version"
Range("C" & 2).Value = "Modified"
Range("D" & 2).Value = "Version & Modified"
End Sub
If anyone can shed some light on this issue - it will be greatly appreciated.
===EDIT===
This is the code I have come up with which always gives me the same time as displayed in an explorer window:
Sub GetFileDetails()
Dim path As String
Dim objFSO As Object
Dim objFile As Object
Dim objFolder As Object
Dim loopCount As Integer
Dim pathCheck As Boolean
Dim modDate As Date
Dim modHour As Integer
Dim modMin As Integer
'Prompt for directory path
path = InputBox(Prompt:="Enter file path", Title:="Enter file path", Default:="")
If (path = "" Or path = vbNullString) Then
MsgBox ("Invalid path - exiting")
Exit Sub
End If
'Required for interacting with filesystem
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder(path)
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
Range("B" & loopCount).Value = objFSO.GetFileVersion(objFile)
Range("D" & loopCount).Value = objFile.Name
'The date modified time for files made in Summer Time are correct, whereas Winter Time will be 1 hour forward
If (IsItSummerTime(objFile.DateLastModified) = True) Then
Range("C" & loopCount).Value = objFile.DateLastModified
Else
modDate = Format(objFile.DateLastModified, "DD-MM-YYYY")
modHour = Hour(objFile.DateLastModified)
modMin = Minute(objFile.DateLastModified)
modHour = modHour - 1
If (modHour < 10) Then
If (modMin < 10) Then
Range("C" & loopCount).Value = modDate & " 0" & modHour & ":0" & modMin
Else
Range("C" & loopCount).Value = modDate & " 0" & modHour & ":" & modMin
End If
Else
If (modMin < 10) Then
Range("C" & loopCount).Value = modDate & " " & modHour & ":0" & modMin
Else
Range("C" & loopCount).Value = modDate & " " & modHour & ":" & modMin
End If
End If
End If
'Combine Version and Modified
If Range("B" & loopCount).Value <> "" Then
Range("E" & loopCount).Value = Range("B" & loopCount).Value & ", " & Range("C" & loopCount).Value
Else
Range("E" & loopCount).Value = Range("C" & loopCount).Value
End If
loopCount = loopCount + 1
Next
'Set up headings
Range("A" & 1).Value = (loopCount - 3) & " files found in " & path
Range("A" & 2).Value = "FileName"
Range("B" & 2).Value = "Version"
Range("C" & 2).Value = "Modified"
Range("D" & 2).Value = "FileName"
Range("E" & 2).Value = "Version & Modified"
End Sub
Function IsItSummerTime(inDate As Date) As Boolean
Dim inDateYear As Integer
Dim findFirstSunday As Date
Dim firstSundayDate As Date
Dim startDays As Integer
Dim endDays As Integer
Dim summerStart As Date
Dim summerEnd As Date
'Summer Time starts on the 13th week
'Summer Time ends on the 42nd week
If (IsItALeapYear(inDate) = True) Then
startDays = (12 * 7) + 1
endDays = (42 * 7) + 1
Else
startDays = 12 * 7
endDays = 42 * 7
End If
'Find the date of the first Sunday in the year
inDateYear = Year(inDate)
For i = 1 To 7
findFirstSunday = DateSerial(inDateYear, 1, i)
If (Weekday(findFirstSunday) = 1) Then
firstSundayDate = findFirstSunday
End If
Next i
'Calculate the start and end dates for Summer Time
summerStart = firstSundayDate + startDays
summerEnd = firstSundayDate + endDays
'Compare inDate to Summer Time values and return boolean value
If (inDate >= summerStart And inDate < summerEnd) Then
IsItSummerTime = True
Else
IsItSummerTime = False
End If
End Function
Function IsItALeapYear(inDate As Date) As Boolean
If (Month(DateSerial(Year(inDate), 2, 29))) = 2 Then
IsItALeapYear = True
Else
IsItALeapYear = False
End If
End Function
It looks like this is ultimately an OS issue that you'd have to work around, like has been shown, especially since you've edited your code to account for DST.
But you could also use the FileDateTime function. The help article for this points out that the result of this function is based on your system's locale settings. The help article for the DateLastModified property doesn't provide any such caveats, at least for Excel online help.
To modify an exerpt from your edited code above:
'1st row for path title, 2nd row for column headings
loopCount = 3
For Each objFile In objFolder.Files
Range("A" & loopCount).Value = objFile.Name
'use the full path name
Range("B" & loopCount).Value = FileDateTime(objFile_fullpathname)
Range("D" & loopCount).Value = objFile.Name