gmaxey
08-24-2017, 07:15 AM
A Word VBA dabbler coming back for more Excel assistance. Sorry if the title is unclear, but I couldn't think of anything better.
Last week, I posted in this forum asking from some help writing the output of a variant array to columns A and B in an Excel sheet. Thanks again.
The values are A (a file name) and B (a folder path). Both A and B are valid. When put together, they form a complete file path. To demonstrate here is the code (run from Excel) the writes the data from a test folder "D:\Test" in which I have two test files.
Sub CreateFileList()
Dim strPath As String
Dim varFileList As Variant
Dim lngIndex As Long
Dim lngCounter As Long
Dim lngPosit As Long
Dim oWB As Workbook
Dim oSheet As Worksheet
Dim varTemp
strPath = "D:\Test\" 'Change to suit.
varFileList = fcnGetList(strPath, 1)
If UBound(varFileList) = -1 Then GoTo lbl_Exit
ReDim varTemp(1 To UBound(varFileList) + 1, 1 To 2)
For lngIndex = LBound(varFileList) To UBound(varFileList)
If varFileList(lngIndex) <> "" Then
lngCounter = lngCounter + 1
lngPosit = InStrRev(varFileList(lngIndex), "\")
'Lists files in first column/folders in second column.
varTemp(lngCounter, 1) = Mid(varFileList(lngIndex), lngPosit + 1, Len(varFileList(lngIndex)))
varTemp(lngCounter, 2) = Mid(varFileList(lngIndex), 1, lngPosit)
End If
Next lngIndex
Set oWB = ThisWorkbook
Set oSheet = oWB.Sheets(1)
oSheet.Range("A1").Resize(lngCounter, UBound(varTemp, 2)).Value = varTemp
oSheet.Sort.SortFields.Clear
oSheet.Sort.SortFields.Add key:=oSheet.Range("A1"), SortOn:=0, Order:=1, DataOption:=0
With oSheet.Sort
.SetRange oSheet.UsedRange
.Header = 1
.MatchCase = False
.Orientation = 1
.SortMethod = 1
.Apply
End With
Application.Columns("A:B").EntireColumn.AutoFit
lbl_Exit:
Set oWB = Nothing: Set oSheet = Nothing
Exit Sub
End Sub
Function fcnGetList(strFolder, lngRouter)
Dim strOutPut As String
Dim oShell, oFSO As Object
Dim lngIndex As Long
Dim varTemp
If Not Right(strFolder, 1) = "\" Then strFolder = strFolder & "\"
Set oShell = CreateObject("wscript.shell")
'Note, I used this method to avoid the black command prompt that is displayed if Shell.Exec is used.
Select Case lngRouter
Case 1: oShell.Run "cmd /c Dir """ & strFolder & "*"" /a:-d/s/ogn/b > C:\FileListOut.txt", 0, 1
Case 2: oShell.Run "cmd /c Dir """ & strFolder & "*"" /a:-d/ogn/b > C:\FileListOut.txt", 0, 1
End Select
Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO
strOutPut = .OpenTextFile("C:\FileListOut.txt").ReadAll()
.DeleteFile "C:\FileListOut.txt"
End With
If Right(strOutPut, 1) = Chr(10) Then strOutPut = Left(strOutPut, Len(strOutPut) - 1)
varTemp = Split(strOutPut, vbCrLf)
If lngRouter = 2 Then
For lngIndex = 0 To UBound(varTemp)
varTemp(lngIndex) = strFolder & varTemp(lngIndex)
Next lngIndex
End If
fcnGetList = varTemp
lbl_Exit:
Set oShell = Nothing: Set oFSO = Nothing
Exit Function
End Function
Public Function fcnFileOrFolderExist(PathName As String) As Boolean
Dim lngTemp As Long
On Error Resume Next
lngTemp = GetAttr(PathName)
Select Case Err.Number
Case Is = 0: fcnFileOrFolderExist = True
Case Else
fcnFileOrFolderExist = False
End Select
On Error GoTo 0
lbl_Exit:
Exit Function
End Function
All is well to this point. Next I have added a procedure which I run after the list is prepared that returns file attributes in columns C-G.
Sub FillInFileDetails()
Dim oSheet As Worksheet
Dim oRow As Range
Dim oFSO As Object
Dim oFile As Object
Dim lngCount As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oSheet = ActiveSheet
lngCount = 0
On Error GoTo Err_File
For Each oRow In oSheet.Rows
If oSheet.Cells(oRow.Row, 1).Value = "" Then Exit For
lngCount = lngCount + 1
Set oFile = oFSO.GetFile(oSheet.Cells(lngCount, 2) & oSheet.Cells(lngCount, 1))
With oSheet
.Cells(lngCount, 3).Value = oFile.DateCreated
.Cells(lngCount, 4).Value = oFile.DateLastAccessed
.Cells(lngCount, 5).Value = oFile.DateLastModified
.Cells(lngCount, 6).Value = oFile.Size
.Cells(lngCount, 7).Value = oFile.Type
End With
Err_ReEntry:
DoEvents
Next oRow
On Error GoTo 0
lbl_Exit:
Exit Sub
Err_File:
oSheet.Cells(lngCount, 3).Value = "Error accessing file"
Resume Err_ReEntry
End Sub
This is where I am having trouble. For some inexplicable reason, the file/path pair in the last row always returns an error. I have handled the error and write "Error accessing file" in column C. Here is the weird part. Say the file name showing the last row of column A is "B.docm" or "B.xlsm", if I simply put the cursor in that cell, and retype the file name I can then run the procedure again and it works with no error.
It seems that for whatever reason, the code above that writes the values to the cells:
oSheet.Range("A1").Resize(lngCounter, UBound(varTemp, 2)).Value = varTemp
or the subsequent sort is making that cell look like one thing but being in fact something unrecognizable to the FileSystemObject. I hope that makes sense.
Anyone have an idea why this is occurring and how to fix it? Also open to any advise to improve on either procedure. Thanks!
Last week, I posted in this forum asking from some help writing the output of a variant array to columns A and B in an Excel sheet. Thanks again.
The values are A (a file name) and B (a folder path). Both A and B are valid. When put together, they form a complete file path. To demonstrate here is the code (run from Excel) the writes the data from a test folder "D:\Test" in which I have two test files.
Sub CreateFileList()
Dim strPath As String
Dim varFileList As Variant
Dim lngIndex As Long
Dim lngCounter As Long
Dim lngPosit As Long
Dim oWB As Workbook
Dim oSheet As Worksheet
Dim varTemp
strPath = "D:\Test\" 'Change to suit.
varFileList = fcnGetList(strPath, 1)
If UBound(varFileList) = -1 Then GoTo lbl_Exit
ReDim varTemp(1 To UBound(varFileList) + 1, 1 To 2)
For lngIndex = LBound(varFileList) To UBound(varFileList)
If varFileList(lngIndex) <> "" Then
lngCounter = lngCounter + 1
lngPosit = InStrRev(varFileList(lngIndex), "\")
'Lists files in first column/folders in second column.
varTemp(lngCounter, 1) = Mid(varFileList(lngIndex), lngPosit + 1, Len(varFileList(lngIndex)))
varTemp(lngCounter, 2) = Mid(varFileList(lngIndex), 1, lngPosit)
End If
Next lngIndex
Set oWB = ThisWorkbook
Set oSheet = oWB.Sheets(1)
oSheet.Range("A1").Resize(lngCounter, UBound(varTemp, 2)).Value = varTemp
oSheet.Sort.SortFields.Clear
oSheet.Sort.SortFields.Add key:=oSheet.Range("A1"), SortOn:=0, Order:=1, DataOption:=0
With oSheet.Sort
.SetRange oSheet.UsedRange
.Header = 1
.MatchCase = False
.Orientation = 1
.SortMethod = 1
.Apply
End With
Application.Columns("A:B").EntireColumn.AutoFit
lbl_Exit:
Set oWB = Nothing: Set oSheet = Nothing
Exit Sub
End Sub
Function fcnGetList(strFolder, lngRouter)
Dim strOutPut As String
Dim oShell, oFSO As Object
Dim lngIndex As Long
Dim varTemp
If Not Right(strFolder, 1) = "\" Then strFolder = strFolder & "\"
Set oShell = CreateObject("wscript.shell")
'Note, I used this method to avoid the black command prompt that is displayed if Shell.Exec is used.
Select Case lngRouter
Case 1: oShell.Run "cmd /c Dir """ & strFolder & "*"" /a:-d/s/ogn/b > C:\FileListOut.txt", 0, 1
Case 2: oShell.Run "cmd /c Dir """ & strFolder & "*"" /a:-d/ogn/b > C:\FileListOut.txt", 0, 1
End Select
Set oFSO = CreateObject("Scripting.FileSystemObject")
With oFSO
strOutPut = .OpenTextFile("C:\FileListOut.txt").ReadAll()
.DeleteFile "C:\FileListOut.txt"
End With
If Right(strOutPut, 1) = Chr(10) Then strOutPut = Left(strOutPut, Len(strOutPut) - 1)
varTemp = Split(strOutPut, vbCrLf)
If lngRouter = 2 Then
For lngIndex = 0 To UBound(varTemp)
varTemp(lngIndex) = strFolder & varTemp(lngIndex)
Next lngIndex
End If
fcnGetList = varTemp
lbl_Exit:
Set oShell = Nothing: Set oFSO = Nothing
Exit Function
End Function
Public Function fcnFileOrFolderExist(PathName As String) As Boolean
Dim lngTemp As Long
On Error Resume Next
lngTemp = GetAttr(PathName)
Select Case Err.Number
Case Is = 0: fcnFileOrFolderExist = True
Case Else
fcnFileOrFolderExist = False
End Select
On Error GoTo 0
lbl_Exit:
Exit Function
End Function
All is well to this point. Next I have added a procedure which I run after the list is prepared that returns file attributes in columns C-G.
Sub FillInFileDetails()
Dim oSheet As Worksheet
Dim oRow As Range
Dim oFSO As Object
Dim oFile As Object
Dim lngCount As Long
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oSheet = ActiveSheet
lngCount = 0
On Error GoTo Err_File
For Each oRow In oSheet.Rows
If oSheet.Cells(oRow.Row, 1).Value = "" Then Exit For
lngCount = lngCount + 1
Set oFile = oFSO.GetFile(oSheet.Cells(lngCount, 2) & oSheet.Cells(lngCount, 1))
With oSheet
.Cells(lngCount, 3).Value = oFile.DateCreated
.Cells(lngCount, 4).Value = oFile.DateLastAccessed
.Cells(lngCount, 5).Value = oFile.DateLastModified
.Cells(lngCount, 6).Value = oFile.Size
.Cells(lngCount, 7).Value = oFile.Type
End With
Err_ReEntry:
DoEvents
Next oRow
On Error GoTo 0
lbl_Exit:
Exit Sub
Err_File:
oSheet.Cells(lngCount, 3).Value = "Error accessing file"
Resume Err_ReEntry
End Sub
This is where I am having trouble. For some inexplicable reason, the file/path pair in the last row always returns an error. I have handled the error and write "Error accessing file" in column C. Here is the weird part. Say the file name showing the last row of column A is "B.docm" or "B.xlsm", if I simply put the cursor in that cell, and retype the file name I can then run the procedure again and it works with no error.
It seems that for whatever reason, the code above that writes the values to the cells:
oSheet.Range("A1").Resize(lngCounter, UBound(varTemp, 2)).Value = varTemp
or the subsequent sort is making that cell look like one thing but being in fact something unrecognizable to the FileSystemObject. I hope that makes sense.
Anyone have an idea why this is occurring and how to fix it? Also open to any advise to improve on either procedure. Thanks!