'Change p value and 1st input to aFFs() to suit.
Sub Main()
'https://docs.microsoft.com/en-us/dotnet/visual-basic/programming-guide/language-features/data-types/type-characters
Dim p$, s$, a$, r&, n, nn, i&, fso As Object
p = ThisWorkbook.path & "\Test"
s = "Sheet1"
a = "A1"
n = aFFs(p & "\*.xlsx", "/o:n") 'Order by filename.
If Not IsArray(n) Then Exit Sub
ReDim nn(0 To UBound(n))
Set fso = CreateObject("Scripting.FileSystemObject")
For i = 0 To UBound(n)
nn(i) = GetValue(p, fso.GetBasename(n(i)), s, a)
Next i
Range("B1").Resize(1 + UBound(n)).Value = _
WorksheetFunction.Transpose(nn)
Set fso = Nothing
End Sub
'Retrieves a value from a closed workbook
Private Function GetValue(path, file, sheet, ref)
Dim arg As String
'path = "d:\files"
'file = "budget.xls"
'sheet = "Sheet1"
'ref = "A1:R30"
'Make sure the file exists
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & file) = "" Then
GetValue = CVErr(xlErrNA)
End If
'Create the argument
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
'Execute an XLM macro
GetValue = ExecuteExcel4Macro(arg)
End Function
'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
Optional tfSubFolders As Boolean = False) As Variant
Dim s As String, a() As String, v As Variant
Dim b() As Variant, i As Long
If tfSubFolders Then
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b /s " & extraSwitches).StdOut.ReadAll
Else
s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
"""" & myDir & """" & " /b " & extraSwitches).StdOut.ReadAll
End If
a() = Split(s, vbCrLf)
If UBound(a) = -1 Then
Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
Exit Function
End If
ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr
For i = 0 To UBound(a)
If Not tfSubFolders Then
s = Left$(myDir, InStrRev(myDir, "\"))
'add the folder name
a(i) = s & a(i)
End If
Next i
aFFs = sA1dtovA1d(a)
End Function
Function sA1dtovA1d(strArray() As String) As Variant
Dim varArray() As Variant, i As Long
ReDim varArray(LBound(strArray) To UBound(strArray))
For i = LBound(strArray) To UBound(strArray)
varArray(i) = CVar(strArray(i))
Next i
sA1dtovA1d = varArray()
End Function
'http://www.vbaexpress.com/forum/showthread.php?48491
Function ArrayListSort(sn As Variant, Optional bAscending As Boolean = True)
With CreateObject("System.Collections.ArrayList")
Dim cl As Variant
For Each cl In sn
.Add cl
Next
.Sort 'Sort ascendending
If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
ArrayListSort = .Toarray()
End With
End Function
