I've written some VBA to go through a folder and consolidate spreadsheets onto one masterfile. One of the first things I needed to do was to look for all files in a folder with the extension .xl*.
I wrote this on a Windows box, and now someone wants to run this on a Mac.
I have changes the line from
Fname = Dir(ThisWorkbook.Path & "/*.xl*")
to
Fname = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xl*")
but I get a: run time error 68 - device not available error
How can I get this line running on a Mac?
For reference here is the complete code:
Sub Consolidation()
Application.ScreenUpdating = False
'find last record in mastersheet
Set destsheet = ThisWorkbook.Worksheets("Consolidated")
Set MyRange = Worksheets("Consolidated").Range("C" & "1")
lngLastRow = Cells(Rows.Count, MyRange.Column).End(xlUp).Row
'looks for files with the follwing extension
'Fname = Dir(ThisWorkbook.Path & "/*.xl*")
Fname = Dir(ThisWorkbook.Path & Application.PathSeparator & "*.xl*")
'cycles through the folder
Do While Fname <> ""
If Fname <> ThisWorkbook.Name Then
Application.StatusBar = "Processing: " & Fname
Set wkbkorigin = Workbooks.Open(ThisWorkbook.Path & "/" & Fname)
Set originsheet = wkbkorigin.Worksheets("Sheet1")
n = 0
m = 0
'adds recods to the next avaibale row
'destsheet.Range("B4").Offset(lngLastRow + 1, 1) = originsheet.Range("E4").Value
destsheet.Range("C" & lngLastRow + 1) = originsheet.Range("E4").Value
destsheet.Range("D" & lngLastRow + 1) = originsheet.Range("E5").Value
destsheet.Range("E" & lngLastRow + 1) = originsheet.Range("E6").Value
destsheet.Range("F" & lngLastRow + 1) = originsheet.Range("E7").Value
destsheet.Range("G" & lngLastRow + 1) = originsheet.Range("E8").Value
destsheet.Range("H" & lngLastRow + 1) = originsheet.Range("E9").Value
destsheet.Range("I" & lngLastRow + 1) = originsheet.Range("E10").Value
lngLastRow = lngLastRow + 1
wkbkorigin.Close SaveChanges:=False 'close current file
End If
'stips when out of files to import
Fname = Dir()
Loop
Application.ScreenUpdating = True
End Sub
Try setting the Files and Folders permission on MacOS Security Preferences pane for Excel.
Related
I have the following code, that basically copies databases from some files in a folder and pastes in my workbook.
It is supposed to clean everything before starting, and it does when I run from console, hitting F8 and going through it, but when I click the button to which I have assigned the Macro, it does not clean the old base before getting the new ones, then I get old data and then new data below it.
Do you know what can cause it?
Thank you!
Sub Atualizar_B_Un_Time()
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Dim base_5 As Workbook
Dim plan_5 As Worksheet
Dim aux As String
Dim caminho As String
Dim nome_arquivo_5 As String
Dim destino_5 As Worksheet
Dim dia As String
Set destino_5 = ThisWorkbook.Worksheets("B_Un_Time")
caminho = Application.ActiveWorkbook.Path
nome_arquivo_5 = Dir(caminho & "\IC_Reports_AgentUnavailableTime*.xlsx")
destino_5.Range("H2:L" & Cells(Rows.Count, "I").End(xlUp).Row).UnMerge
destino_5.Range("F2:F" & Cells(Rows.Count, "F").End(xlUp).Row).ClearContents
destino_5.Range("H2:L" & Cells(Rows.Count, "I").End(xlUp).Row).ClearContents
Do While nome_arquivo_5 <> ""
aux = caminho & "\" & nome_arquivo_5
Set base_5 = Workbooks.Open(aux, Local:=True)
Set plan_5 = base_5.Sheets(1)
dia = Mid(nome_arquivo_5, InStr(nome_arquivo_5, "-") + 1, 2)
plan_5.Range("A2:E" & plan_5.Cells(Rows.Count, "B").End(xlUp).Row).Copy _
Destination:=destino_5.Range("H" & (destino_5.Cells(Rows.Count, "I").End(xlUp).Row + 1))
destino_5.Range("F" & (destino_5.Cells(Rows.Count, "F").End(xlUp).Row + 1) & ":" & "F" & _
(destino_5.Cells(Rows.Count, "I").End(xlUp).Row)).Value = Format(Now, "mm/") & dia & Format(Now, "/yyyy")
base_5.Close savechanges:=False
nome_arquivo_5 = Dir
Loop
If IsEmpty(destino_5.Range("A" & destino_5.Cells(Rows.Count, "I").End(xlUp).Row)) Then
destino_5.Range("A2:E2").Copy Destination:=destino_5.Range("A" & (destino_5.Cells(Rows.Count, "A").End(xlUp).Row + 1) _
& ":" & "E" & destino_5.Cells(Rows.Count, "I").End(xlUp).Row)
destino_5.Range("G2").Copy Destination:=destino_5.Range("G" & (destino_5.Cells(Rows.Count, "G").End(xlUp).Row + 1) & ":" & _
"G" & destino_5.Cells(Rows.Count, "I").End(xlUp).Row)
ElseIf Not IsEmpty(destino_5.Range("A" & (destino_5.Cells(Rows.Count, "I").End(xlUp).Row + 1))) Then
destino_5.Rows((destino_5.Cells(Rows.Count, "I").End(xlUp).Row + 1) & ":" & destino_5.Cells(Rows.Count, "A") _
.End(xlUp).Row).EntireRow.Delete
End If
destino_5.Cells.Font.Name = "Calibri"
destino_5.Cells.Font.Size = 8
destino_5.Rows.RowHeight = 11.25
Application.DisplayAlerts = True 'turn system alerts back on
Application.EnableEvents = True 'turn other macros back on
Application.ScreenUpdating = True 'refreshes the screen
End Sub
It's probably because you haven't added a sheet references everywhere. and hence are referencing the active sheet. Try amending that section thus (note the dots):
With destino_5
.Range("H2:L" & .Cells(.Rows.Count, "I").End(xlUp).Row).UnMerge
.Range("F2:F" & .Cells(.Rows.Count, "F").End(xlUp).Row).ClearContents
.Range("H2:L" & .Cells(.Rows.Count, "I").End(xlUp).Row).ClearContents
End With
I adjusted the code I found on the Internet to pull data from the files in the folder and put them in one master sheet.
However, the numer of files will grow very quickly every week, so for that reason I would like to implement in the code that macro will skip the files that were already processed. I would like to do it by the looking up the file name in the master sheet (column U).
Please find the code below:
Option Explicit
Const FOLDER_PATH = "Z:\...\...\...\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim fName As String
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
Dim wsMaster As Worksheet
Dim NR As Long
rowTarget = 3
'Setup
Application.ScreenUpdating = False 'speed up macro execution
Application.EnableEvents = False 'turn off other macros for now
Application.DisplayAlerts = False 'turn off system messages for now
Set wsMaster = ThisWorkbook.Sheets("Arkusz1") 'sheet report is built into
With wsMaster
If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
.UsedRange.Offset(2).Columns(3).Clear
.UsedRange.Offset(2).Columns(4).Clear
.UsedRange.Offset(2).Columns(5).Clear
.UsedRange.Offset(2).Columns(6).Clear
.UsedRange.Offset(2).Columns(7).Clear
.UsedRange.Offset(2).Columns(8).Clear
.UsedRange.Offset(2).Columns(9).Clear
.UsedRange.Offset(2).Columns(10).Clear
.UsedRange.Offset(2).Columns(11).Clear
.UsedRange.Offset(2).Columns(12).Clear
.UsedRange.Offset(2).Columns(13).Clear
.UsedRange.Offset(2).Columns(14).Clear
.UsedRange.Offset(2).Columns(15).Clear
.UsedRange.Offset(2).Columns(17).Clear
.UsedRange.Offset(2).Columns(18).Clear
.UsedRange.Offset(2).Columns(20).Clear
NR = 3
Else
NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1 'appends data to existing data
End If
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = False
'set up the target worksheet
Set wsTarget = Sheets("Arkusz1")
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets(3) 'EDIT IF NECESSARY
'import the data
With wsTarget
.Range("C" & rowTarget).Value = wsSource.Range("F4").Value
.Range("D" & rowTarget).Value = wsSource.Range("J4").Value
.Range("E" & rowTarget).Value = wsSource.Range("J7").Value
.Range("F" & rowTarget).Value = wsSource.Range("J10").Value
.Range("G" & rowTarget).Value = wsSource.Range("J19").Value
.Range("H" & rowTarget).Value = wsSource.Range("L19").Value
.Range("I" & rowTarget).Value = wsSource.Range("H17").Value
.Range("J" & rowTarget).Value = wsSource.Range("N27").Value
.Range("K" & rowTarget).Value = wsSource.Range("N29").Value
.Range("L" & rowTarget).Value = wsSource.Range("N36").Value
.Range("M" & rowTarget).Value = wsSource.Range("N38").Value
.Range("N" & rowTarget).Value = wsSource.Range("J50").Value
.Range("O" & rowTarget).Value = wsSource.Range("L50").Value
.Range("Q" & rowTarget).Value = wsSource.Range("J52").Value
.Range("R" & rowTarget).Value = wsSource.Range("L52").Value
.Range("T" & rowTarget).Value = wsSource.Range("N57").Value
'optional source filename in the last column
.Range("U" & rowTarget).Value = sFile
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
End If
'Format columns to the desired format
.UsedRange.Offset(2).Columns(7).NumberFormat = "### ### ##0"
.UsedRange.Offset(2).Columns(8).NumberFormat = "### ### ##0"
.UsedRange.Offset(2).Columns(9).NumberFormat = "#,##0.00 $"
.UsedRange.Offset(2).Columns(10).NumberFormat = "#,##0.00 $"
.UsedRange.Offset(2).Columns(11).NumberFormat = "#,##0.00 $"
.UsedRange.Offset(2).Columns(12).NumberFormat = "#,##0.00 $"
.UsedRange.Offset(2).Columns(13).NumberFormat = "#,##0.00 $"
.UsedRange.Offset(2).Columns(14).NumberFormat = "0.00%"
.UsedRange.Offset(2).Columns(15).NumberFormat = "0.00%"
.UsedRange.Offset(2).Columns(16).NumberFormat = "0.00%"
.UsedRange.Offset(2).Columns(17).NumberFormat = "0.00%"
.UsedRange.Offset(2).Columns(18).NumberFormat = "0.00%"
.UsedRange.Offset(2).Columns(19).NumberFormat = "0.00%"
.UsedRange.Offset(2).Columns(20).NumberFormat = "0.00%"
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
End With
End Sub
Private Function FileFolderExists(strPath As String) As Boolean
If Not Dir(strPath, vbDirectory) = vbNullString Then FileFolderExists = True
End Function
I tried to make it by If and GoTo statement but I have very little knowledge in VBA and I have no idea how to actually formulate it skip files which names are already in master sheet.
Thanks in advance!
I'll assume for the moment that the file name in column U is the entire path with file extension. i.e. C:\Users\SL\Desktop\TestFile.xls
You can use the Find method to look for any entries in column U that match sFile at the start of each loop. If a match is found, skip over the file and move on, otherwise process it. Make sure you place sFile = Dir() outside the If statement to avoid an infinite loop.
Dim PathMatch As Range
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
With wsMaster.Range("U:U")
Set PathMatch = .Find(What:=sFile, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
If Not PathMatch Is Nothing Then
Debug.Print "File already processed, skip to next file."
Else
Debug.Print "File not processed yet, do it now"
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets(3) 'EDIT IF NECESSARY
'import the data
With wsTarget
.Range("C" & rowTarget).Value = wsSource.Range("F4").Value
.Range("D" & rowTarget).Value = wsSource.Range("J4").Value
.Range("E" & rowTarget).Value = wsSource.Range("J7").Value
.Range("F" & rowTarget).Value = wsSource.Range("J10").Value
.Range("G" & rowTarget).Value = wsSource.Range("J19").Value
.Range("H" & rowTarget).Value = wsSource.Range("L19").Value
.Range("I" & rowTarget).Value = wsSource.Range("H17").Value
.Range("J" & rowTarget).Value = wsSource.Range("N27").Value
.Range("K" & rowTarget).Value = wsSource.Range("N29").Value
.Range("L" & rowTarget).Value = wsSource.Range("N36").Value
.Range("M" & rowTarget).Value = wsSource.Range("N38").Value
.Range("N" & rowTarget).Value = wsSource.Range("J50").Value
.Range("O" & rowTarget).Value = wsSource.Range("L50").Value
.Range("Q" & rowTarget).Value = wsSource.Range("J52").Value
.Range("R" & rowTarget).Value = wsSource.Range("L52").Value
.Range("T" & rowTarget).Value = wsSource.Range("N57").Value
'optional source filename in the last column
.Range("U" & rowTarget).Value = sFile
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
End If
sFile = Dir()
Loop
If you only have the file name and not the path you'll need to parse sFile accordingly. Here are a few ways to do that.
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 to copy data from multiple excel files named with numbers (1.xlsx, 2.xlsx, 3.xlsx, etc). I wrote this macro. It runs. But no copy happens, the main workbook in which I ran the macro remains empty.
Sub filecopy()
' The macro is running in the main file, which I saved as .xlsm
' This main.xlsm is in the same folder as the files from which I copy the data
Dim Filename As String, Pathname As String,xx as Double
Activesheet.Usedrange.Clear 'I delete the current contents of the sheet
Pathname = ActiveWorkbook.Path
Filename = Dir(Pathname & "*.xlsx")
xx = 1 'the first column where the contents of the first file goes
Do While Len(Filename) > 0
Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!A1"
Cells(2, xx).Formula = "='[" & Filename & "]Sheet1'!B2"
Cells(3, xx).Formula = "='[" & Filename & "]Sheet1'!C3"
xx = xx + 1 'next file next column
Filename = Dir()
Loop
ActiveSheet.UsedRange.Value = ActiveSheet.UsedRange.Value 'every formula goes to value
MsgBox "Work Complete", vbInformation
End Sub
There are 2 errors in your code:
1. \ is missing -> filename is empty
Replace Filename = Dir(Pathname & "*.xlsx") with Filename = Dir(Pathname & "\*.xlsx")
2. the formula is not correct -> not complete filename
Change your formulas e.g. Cells(1, xx).Formula = "='[" & Filename & "]Sheet1'!A1" with this Cells(1, xx).Formula = "='" & Pathname & "\[" & Filename & "]Sheet1'!A1"
What about a solution like this:
Pathname = ActiveWorkbook.Path 'Be sure is the rigth path
Filename = Dir(Pathname & "\*.xlsx") 'I've addedd a "\"
xx = 1
Do While Len(Filename) > 0
If Filename <> ThisWorkbook.Name Then
Set mFile = Workbooks.Open(Pathname & "\" & Filename)
Else
GoTo NextFile
End If
With mFile.ActiveSheet 'Use the sheet you need here
Cells(1, xx) = .Cells(1, 1).Value
Cells(2, xx) = .Cells(2, 1).Value
Cells(3, xx) = .Cells(3, 1).Value
End With
xx = xx + 1 'next file next column
Application.DisplayAlerts = False
mFile.Close savechanges:=False
Application.DisplayAlerts = True
Set mFile = Nothing
NextFile:
Filename = Dir()
Loop
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