Sub Main()
Dim vv() As Variant, aPath As String, v As Variant, c As Range
Dim s() As String, a() As Variant, fso As Object
'Change value of aPath to suit your path to account files.
'aPath = "C:\Users\lenovo1\Dropbox\Excel\FileFolder\Accounts\"
aPath = ThisWorkbook.path & "\"
'Speed things up a bit as data is written to master file, ActiveWorkbook.
'On Error GoTo EndSub
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set fso = CreateObject("Scripting.FileSystemObject")
'Fill variant array with full paths to account "xlsm" files.
vv() = aFFs(aPath & "*.xlsm")
'MsgBox Join(vv, vbLf)
'Set first empty cell in column A, first Worksheet, in ActiveWorkbook, master file.
Set c = Worksheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1)
'Fill first row in ActiveWorkbook, first Worksheet, with column headings, if needed in loop.
a() = Array("Account Name", "Report Date", "Closing Balance", "Ledger Balance")
If Worksheets(1).Range("A1").Value = "" Then Worksheets(1).Range("A1:D1").Value = a()
'Iterate filenames in vv() and fill ActiveWorkbook.
For Each v In vv()
'Skip master file in vv(), ThisWorkbook, if it is in the accounts folder.
If v = ThisWorkbook.FullName Then GoTo NextV
'Get the data from the account files in vv() and poke into ThisWorkbook.
'Account Name, from account filename:
c.Value = fso.GetBasename(v)
'Report Date, A1 in account file:
c.Offset(, 1).Value = GetValue(fso.GetParentFolderName(v), _
fso.GetFilename(v), "Sheet1", "A1")
'Set date format for Report Date:
'c.Offset(, 1).NumberFormat = "mm/dd/yyyy"
'Balance, B8 in account file:
c.Offset(, 2).Value = GetValue(fso.GetParentFolderName(v), _
fso.GetFilename(v), "Sheet1", "B8")
'Ledger, C10 in account file:
c.Offset(, 3).Value = GetValue(fso.GetParentFolderName(v), _
fso.GetFilename(v), "Sheet1", "C10")
'Get next empty Column A cell.
Set c = c.Offset(1)
NextV:
Next v
'Autofit columns A:D
Worksheets(1).Columns("A:D").AutoFit
EndSub:
With Application
.EnableEvents = False
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
On Error Resume Next
Set fso = Nothing
End Sub
'http://www.vbaexpress.com/kb/getarticle.php?kb_id=454
'http://spreadsheetpage.com/index.php/tip/a_vba_function_to_get_a_value_from_a_closed_file/
'=GetValue("c:\files", "budget.xls", "Sheet1", "A1")
Function GetValue(path, File, sheet, ref)
' path = "d:\files"
' file = "budget.xls"
' sheet = "Sheet1"
' ref = "A1:R30"
Dim arg As String
If Right(path, 1) <> "\" Then path = path & "\"
If Dir(path & File) = "" Then
GetValue = "file not found"
Exit Function
End If
arg = "'" & path & "[" & File & "]" & sheet & "'!" & _
Range(ref).Range("a1").Address(, , xlR1C1)
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
MsgBox 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
Reply With Quote
Originally Posted by Kenneth Hobs
