I'm trying to copy data from excel to fallible PDF form. with below code, I open fallible form and populate the data and I need to save using varibale 'pr' .
While saving it is throwing run time error
"Object doesn't support this property or method"
Dim fcount As Long
Dim sFieldName As String
Set AcrobatApplication = CreateObject("AcroExch.App")
Set AcrobatDocument = CreateObject("AcroExch.AVDoc")
If AcrobatDocument.Open("C:\Users\Desktop\Projects\Jan 2018\Excel to PDF\Test.pdf", "") Then
AcrobatApplication.Show
Set AcroForm = CreateObject("AFormAut.App")
Set Fields = AcroForm.Fields
fcount = Fields.Count ' Number of Fields
With ThisWorkbook.Sheets(1)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
Fields("Enter county name").Value = Range("A" & i).Value
Fields("Enter county served").Value = Range("B" & i).Value
Fields("Parcel number").Value = Range("C" & i).Value
pr = Range("C" & i).Value
Fields("Property owner name").Value = Range("D" & i).Value
fname = "C:\Users\Desktop\Projects\Jan 2018\Excel to PDF\docs\" & pr & ".pdf"
If AcrobatDocument.Save(PDSaveFull, fname) = False Then
MsgBox ("Cannot save the modified document")
End If
Next
End With
Else
MsgBox "failure"
Dim pr as String
should be enough considering the fact that you are using it only here:
fname = "C:\Users\Desktop\Projects\Jan 2018\Excel to PDF\docs\" & pr & ".pdf"
Related
I am trying to loop a list from a sheet into a Outlook Body, but I just loops through until the end and show the last one...
Any ideas?
Sub SendEmail()
Dim ws As Worksheet
Set ws = Worksheets("PrestageData")
strUsed = ws.UsedRange.Rows.Count
Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)
EmailItem.To = frmForm.txtCollector.Value & "mail.dk"
'EmailItem.CC = "hello#gmail.com"
'EmailItem.BCC = "hhhh#gmail.com"
EmailItem.Subject = "Din FAP er klar til afhentning"
For i = 2 To strUsed
If ws.Cells(i, 4).Value = "KLAR" Then
strReady = ws.Cells(i, 1).Value
EmailItem.HTMLBody = "Hej," & frmForm.txtCollector.Value & "<br><br>" & "Følgende FAP er klar: " & strReady
'Source = ThisWorkbook.FullName
'EmailItem.Attachments.Add Source
End If
Next
EmailItem.Display
End Sub
You are missing an Exit For to leave the loop after the first find:
For i = 2 To strUsed
If ws.Cells(i, 4).Value = "KLAR" Then
strReady = ws.Cells(i, 1).Value
EmailItem.HTMLBody = "Hej," & frmForm.txtCollector.Value & "<br><br>" & "Følgende FAP er klar: " & strReady
Exit For
End If
Next
In case you want to capture multiple matching entries, you have to extend the body rather than replacing it in full. You could append an extra line per entry.
It seems every time in the loop you overwrite the message body. Instead, you need to append the message body with a content found in the worksheet:
EmailItem.HTMLBody = "Hej," & frmForm.txtCollector.Value
For i = 2 To strUsed
If ws.Cells(i, 4).Value = "KLAR" Then
strReady = ws.Cells(i, 1).Value
EmailItem.HTMLBody = EmailItem.HTMLBody & "<br><br>" & "Følgende FAP er klar: " & strReady
'Source = ThisWorkbook.FullName
'EmailItem.Attachments.Add Source
End If
Next
But I'd suggest playing a well-formed HTML markup in the code and find the closing tag in the HTMLBody string and paste your add-in there. For example, you could use the Replace function available in VBA:
EmailItem.HTMLBody = Replace(EmailItem.HTMLBody, "</body>", "<br><br>" & "Følgende FAP er klar: " & strReady & "</body>")
I've got the below code and it works completely fine for rows 1 - 46 on it's own populating one table. As soon as I replicate this with a second table to populate it throws Error1.
I've taken out everything below "' Second Table Entry " and works fine ... put back in and same error. On the "Home" sheet it actually populates the tables information but still throws the error which is stopping further vba from executing.
Any ideas? I've been all over google, stackoverflow, superuser and Microsoft MSDN and can't figure out where in the second bit of code is causing it to error.
EDIT: I've checked the debugger and it's highlighting the below code in the second table inserts
With Worksheets("Home")
.Hyperlinks.Add Anchor:=.Range("H" & row_ptr), _
Address:="", _
SubAddress:=AddStr, _
TextToDisplay:=Workbooks(ActiveWorkbook.Name).Worksheets("Audit_InFlight").Range("D" & i).Value
End With
Any help is greatly appreciated.
Error1
Run-time error '5': Invalid procedure call or argument
Private Sub Workbook_Open()
Dim row_ptr As Long
Dim i As Long
Dim i2 As Long
Dim rownbrMA_Inflight As Long
Dim rownbrAudit As Long
Dim CurrentWorkbook As Workbook
Dim InputWorksheet As Worksheet
Dim DataSourceWorksheet As Worksheet
Dim AuditDataSourceWorksheet As Worksheet
Set CurrentWorkbook = Workbooks(ActiveWorkbook.Name)
Set InputWorksheet = CurrentWorkbook.Sheets("Home")
Set DataSourceWorksheet = CurrentWorkbook.Sheets("MA_Inflight")
Set AuditDataSourceWorksheet = CurrentWorkbook.Sheets("Audit_InFlight")
InputWorksheet.Range("A30:M176").Clear
InputWorksheet.Range("A30:M176").ClearFormats
InputWorksheet.Range("A30:M176").Interior.Color = RGB(255, 255, 255)
rownbrMA_Inflight = DataSourceWorksheet.Range("C" & Rows.Count).End(xlUp).Row
row_ptr = 31
For i = 8 To rownbrMA_Inflight
If DataSourceWorksheet.Range("C" & i).Value = "Open" Then
InputWorksheet.Rows(row_ptr).Insert Shift:=xlDown 'CopyOrigin:=xlFormatFromLeftOrAbove
InputWorksheet.Range("A" & row_ptr).Value = DataSourceWorksheet.Range("E" & i).Value
InputWorksheet.Range("B" & row_ptr).Value = DataSourceWorksheet.Range("F" & i).Value
AddStr = "MA_Inflight!" & "$F$" & CStr(i)
ActiveWorkbook.Activate
Worksheets("Home").Activate
With Worksheets("Home")
.Hyperlinks.Add Anchor:=.Range("B" & row_ptr), _
Address:="", _
SubAddress:=AddStr, _
TextToDisplay:=Workbooks(ActiveWorkbook.Name).Worksheets("MA_Inflight").Range("F" & i).Value
End With
InputWorksheet.Range("C" & row_ptr).Value = DataSourceWorksheet.Range("I" & i).Value
InputWorksheet.Range("D" & row_ptr).Value = DataSourceWorksheet.Range("J" & i).Value
InputWorksheet.Range("E" & row_ptr).Value = DataSourceWorksheet.Range("L" & i).Value
row_ptr = row_ptr + 1
End If
Next i
'============================================================
' Second Table Entry
'============================================================
rownbrAudit = DataSourceWorksheet.Range("C" & Rows.Count).End(xlUp).Row
row_ptr = Empty
row_ptr = 31
For i = 8 To rownbrAudit
If AuditDataSourceWorksheet.Range("B" & i).Value <> "Closed" Then
InputWorksheet.Rows(row_ptr).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
InputWorksheet.Range("G" & row_ptr).Value = AuditDataSourceWorksheet.Range("B" & i).Value
InputWorksheet.Range("H" & row_ptr).Value = AuditDataSourceWorksheet.Range("D" & i).Value
'New code ---------------------------
AddStr = "Audit_InFlight!" & "$D$" & CStr(i)
ActiveWorkbook.Activate
Worksheets("Home").Activate
With Worksheets("Home")
.Hyperlinks.Add Anchor:=.Range("H" & row_ptr), _
Address:="", _
SubAddress:=AddStr, _
TextToDisplay:=Workbooks(ActiveWorkbook.Name).Worksheets("Audit_InFlight").Range("D" & i).Value
End With
'-----------------------------------
InputWorksheet.Range("I" & row_ptr).Value = AuditDataSourceWorksheet.Range("G" & i).Value
InputWorksheet.Range("J" & row_ptr).Value = AuditDataSourceWorksheet.Range("H" & i).Value
InputWorksheet.Range("K" & row_ptr).Value = AuditDataSourceWorksheet.Range("I" & i).Value
InputWorksheet.Range("L" & row_ptr).Value = AuditDataSourceWorksheet.Range("J" & i).Value
InputWorksheet.Range("M" & row_ptr).Value = AuditDataSourceWorksheet.Range("K" & i).Value
row_ptr = row_ptr + 1
End If
Next i
'RemoveBlankCells
'PURPOSE: Deletes single cells that are blank located inside a designated range
Dim rng As Range
'Store blank cells inside a variable
Set rng = InputWorksheet.Range("A30:E50").SpecialCells(xlCellTypeBlanks)
'Delete blank cells and shift upward
rng.Rows.Delete Shift:=xlShiftUp
End Sub
As mentioned in the title, I need a VBA equivalent to the Excel Value function. My data set looks like this: Data set example
What I am looking for is VBA code equivalent to this: =Value(A2)+Value(B2). That would go in column C
The output must be the same as that function. For the given example, column C should end up looking like this: End product
More than that, it needs to only have the value in the cell after the macro is run, rather than displaying the value and still having that formula in it.
Here is what I have done so far:
For i = 1 To LastRow
strValue = Val(sht.Range("A" & i))
strValue1 = Val(sht.Range("B" & i))
sht.Range("C" & i).Value = strValue + strValue1
Next i
I also tried variations on this, a couple of which are shown below:
For i = 1 To LastRow
strValue = Evaluate(sht.Range("A" & i))
strValue1 = Evaluate(sht.Range("B" & i))
sht.Range("C" & i).Value = strValue + strValue1
Next i
For i = 1 To LastRow
strValue = sht.Range("A" & i)
strValue1 = sht.Range("B" & i)
strVal = Evaluate(strValue)
strVal1 = Evaluate(strValue1)
sht.Range("C" & i).Value = strVal + strVal1
Next i
I can't find anything that will work for me. The output in C for the example set ends up being just 9. Pretty sure it is taking the first number in A and adding it to the first number in B. So when the hour in B changes to 1 C displays 10.
I also tried simply:
For i=1 To LastRow
sht.Range("C" & i).Value = sht.Range("A" & i).Value + sht.Range("B" & i).Value
Next i
That just concatenated the text to the format 9/03/15 00:00:00
Any and all help appreciated. Bonus if you can point me in the right direction for changing the final C values from that number (ie. 42250.00017) to the custom date/time format 'yyyy-mm-dd hh:mm:ss'.
Edit: Here is my code up to the sticking point. Everything else works as I want it to, the only problem is with the last For loop.
Sub sbOrganizeData()
Dim i As Long
Dim k As Long
Dim sht As Worksheet
Dim LastRow As Long
Dim sFound As String
Dim rng As Range
Dim sheet As Worksheet
Dim Sheet2 As Worksheet
Dim strFile As String
Dim strCSV As String
Dim strValue As Double
Dim strValue1 As Double
Dim strVal As Long
Dim strVal1 As Long
Application.DisplayAlerts = False
Sheets("all016").Delete
Sheets("Sheet1").Delete
Application.DisplayAlerts = True
Set sheet = Sheets.Add
Set Sheet2 = Sheets.Add
sheet.Name = "all016"
Sheet2.Name = "Sheet1"
strFile = ActiveWorkbook.Path
strCSV = "*.csv"
sFound = Dir(strFile & "\*.csv")
If sFound <> "" Then
Workbooks.Open Filename:=strFile & "\" & sFound
End If
Range("A1").CurrentRegion.Copy Destination:=Workbooks("solar.xlsm").Sheets("all016").Range("A1")
Workbooks(sFound).Close
Set sht = ThisWorkbook.Sheets("all016")
LastRow = sht.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
sht.Range("C1").EntireColumn.Insert
For i = 1 To LastRow
'Code that doesn't quite work here'
sht.Range("C" & i).NumberFormat = "yyyy-mm-dd hh:mm:ss"
Next i
The issue is that the dates and times are strings so something like this will work:
For i = 2 To LastRow
strValue = Evaluate("VALUE(TRIM(" & sht.Range("A" & i).Address(1,1,,1) & "))")
strValue1 = Evaluate("VALUE(TRIM(" & sht.Range("B" & i).Address(1,1,,1) & "))")
sht.Range("C" & i).Value = strValue + strValue1
'the format
sht.Range("C" & i).NumberFormat = "mm/dd/yy hh:mm:ss"
Next i
You have to reference the .Value2 field of the range element as:
For i = 1 To LastRow
sht.Range("C" & i).Value2 = sht.Range("A" & i).Value2 + sht.Range("B" & i).Value2
Next i
The value is free of formatting and just in Excel's time/date code as you want your final result to be. Cheers,
I have a workbook called 'EvaluationLog.xlsm' and I need to transfer specific cells (not the whole row) from the first worksheet to another existing workbook called 'IndicatorLog.xlsm' located in the same directory. The target worksheet is also the first one. I'm trying to have the macro hosted in the 'IndicatorLog' workbook.
Specific cells in each row from the source are only to be copied if the contents in column 'O' is 'No' or if the contents of column 'J' is 'Initial'. The actual source data starts on row 8 and the target range also starts on row 8.
I'm having two issues. The first one is that I'm getting this error 'Application-defined or object-defined error (1004)' at the first line where I'm trying to copy cells.
This is the line: TargetSheet.Range("A" & NRow).Value = WorkBk.ActiveSheet.Range(“A” & i).Value
The second issue is that when I already have the source workbook open, I get a warning about trying to open it again even though I have a function to try to avoid that. :(
I assigned the macro to a form button. Any help will be greatly appreciated! :)
Here are the two Excel files:
Files
Here's the code:
Sub MergeFromLog()
Dim TargetSheet As Worksheet
Dim NRow As Long
Dim SourceFileName As String
Dim WorkBk As Workbook
Dim LastRow As Integer, i As Integer, erow As Integer
' Set destination file.
Set TargetSheet = ActiveWorkbook.Worksheets(1)
' Set source file.
SourceFileName = ActiveWorkbook.Path & "\2015-2016 Evaluation Log.xlsm"
' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 8
' Open the source workbook in the folder
If CheckFileIsOpen(SourceFileName) = False Then
Set WorkBk = Workbooks.Open(SourceFileName)
Else
Set WorkBk = Workbooks(SourceFileName)
End If
LastRow = WorkBk.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For i = 8 To LastRow
If WorkBk.ActiveSheet.Range("O" & i) = "No" Or WorkBk.ActiveSheet.Range("J" & i) = "Initial" Then
' Copy Student Name
TargetSheet.Range("A" & NRow).Value = WorkBk.ActiveSheet.Range(“A” & i).Value
' Copy DOB
TargetSheet.Range("B" & NRow).Value = WorkBk.ActiveSheet.Range(“C” & i).Value
' Copy ID#
TargetSheet.Range("C" & NRow).Value = WorkBk.ActiveSheet.Range(“D” & i).Value
' Copy Consent Day
TargetSheet.Range("D" & NRow).Value = WorkBk.ActiveSheet.Range(“L” & i).Value
' Copy Report Day
TargetSheet.Range("E" & NRow).Value = WorkBk.ActiveSheet.Range(“N” & i).Value
' Copy FIE within District Timelines?
TargetSheet.Range("F" & NRow).Value = WorkBk.ActiveSheet.Range(“O” & i).Value
' Copy Qualified?
TargetSheet.Range("H" & NRow).Value = WorkBk.ActiveSheet.Range(“A” & i).Value
' Copy Primary Eligibility
TargetSheet.Range("I" & NRow).Value = WorkBk.ActiveSheet.Range(“U” & i).Value
' Copy ARD Date
TargetSheet.Range("J" & NRow).Value = WorkBk.ActiveSheet.Range(“R” & i).Value
' Copy ARD within District Timelines?
TargetSheet.Range("K" & NRow).Value = WorkBk.ActiveSheet.Range(“S” & i).Value
' Copy Ethnicity
TargetSheet.Range("M" & NRow).Value = WorkBk.ActiveSheet.Range(“F” & i).Value
' Copy Hisp?
TargetSheet.Range("N" & NRow).Value = WorkBk.ActiveSheet.Range(“G” & i).Value
' Copy Diag/LSSP
TargetSheet.Range("O" & NRow).Value = WorkBk.ActiveSheet.Range(“X” & i).Value
NRow = NRow + 1
End If
Next i
End Sub
Function CheckFileIsOpen(chkSumfile As String) As Boolean
On Error Resume Next
CheckFileIsOpen = UCase(Workbooks(chkSumfile).Name) Like UCase(chkSumfile)
On Error GoTo 0
End Function
You can take advantage of the rarely used Resume with error control.
Sub MergeFromLog2()
Dim SourceSheet As Worksheet, TargetSheet As Worksheet
Dim SourceFileName As String
Dim LastRow As Long, i As Long, NRow As Long
' Set destination file.
Set TargetSheet = ThisWorkbook.Worksheets(1)
NRow = TargetSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1
' Set source file.
On Error GoTo CheckWbIsOpen
SourceFileName = ThisWorkbook.Path & "\2015-2016 Evaluation Log.xlsm"
'Try to work on it as if it was open. If it is closed an error will be thrown and it will be opened and control will be returned back here
Set SourceSheet = Workbooks(Trim(Right(Replace(SourceFileName, "\", Space(99)), 99))).Worksheets(1)
On Error GoTo 0
With SourceSheet
Debug.Print .Name
LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 8 To LastRow
If .Range("O" & i) = "No" Or .Range("J" & i) = "Initial" Then
' Copy Student Name
TargetSheet.Range("A" & NRow).Value = .Range("A" & i).Value
' Copy DOB
TargetSheet.Range("B" & NRow).Value = .Range("C" & i).Value
' Copy ID#
TargetSheet.Range("C" & NRow).Value = .Range("D" & i).Value
' Copy Consent Day
TargetSheet.Range("D" & NRow).Value = .Range("L" & i).Value
' Copy Report Day
TargetSheet.Range("E" & NRow).Value = .Range("N" & i).Value
' Copy FIE within District Timelines?
TargetSheet.Range("F" & NRow).Value = .Range("O" & i).Value
' Copy Qualified?
TargetSheet.Range("H" & NRow).Value = .Range("A" & i).Value
' Copy Primary Eligibility
TargetSheet.Range("I" & NRow).Value = .Range("U" & i).Value
' Copy ARD Date
TargetSheet.Range("J" & NRow).Value = .Range("R" & i).Value
' Copy ARD within District Timelines?
TargetSheet.Range("K" & NRow).Value = .Range("S" & i).Value
' Copy Ethnicity
TargetSheet.Range("M" & NRow).Value = .Range("F" & i).Value
' Copy Hisp?
TargetSheet.Range("N" & NRow).Value = .Range("G" & i).Value
' Copy Diag/LSSP
TargetSheet.Range("O" & NRow).Value = .Range("X" & i).Value
NRow = NRow + 1
End If
Next i
Application.DisplayAlerts = False
.Parent.Close False
End With
GoTo Safe_Exit
CheckWbIsOpen:
i = i + 1
If i > 1 Then
'tried once and failed - do not keep trying to open something that doesn't want to be opened
Debug.Print "Unable to open: " & SourceFileName
Exit Sub
End If
Workbooks.Open Filename:=SourceFileName, ReadOnly:=True
Resume '<- this sends control back to the line that threw the error
Safe_Exit:
Set SourceSheet = Nothing
Set TargetSheet = Nothing
Application.DisplayAlerts = True
End Sub
The error trapping with Resume completely negates the need for your function.
Change your function call:
Function CheckFileIsOpen(chkSumfile As String) As Boolean
Dim ret
ret = False
On Error Resume Next
ret = (Workbooks(chkSumfile).Name <> "")
CheckFileIsOpen = ret
End Function
Otherwise, the ironically-named smart quotes don't work well (or, they don't work at all) with VBA. Fixing those to normal quotes should take care of it.
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