Option Explicit
Option Private Module
Dim InputFolder As String
Dim OutputFolder As String
Dim CurrentFolder As String
Dim wbDestination As Workbook
Dim fso As Object
Dim strFileName As String
Public Sub Select_Folder()
'' Code taken from wellsr.com - https://wellsr.com/vba/2016/excel/vba-select-folder-with-msoFileDialogFolderPicker/
Dim sFolder As String
' Open the select folder prompt
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = "C:\"
If .Show = -1 Then ' if OK is pressed
sFolder = .SelectedItems(1)
End If
End With
If sFolder <> "" Then ' if a file was chosen
' *********************
' put your code in here
' *********************
Settings.Range("StoreFolder").Value = sFolder
End If
End Sub
Public Sub Create_Report()
' Debug.Print "-------------"
' Debug.Print "create report"
Set fso = CreateObject("Scripting.FileSystemObject")
InputFolder = IIf(Settings.Range("StoreFolder").Value = "", ThisWorkbook.Path, Settings.Range("StoreFolder").Value)
OutputFolder = fso.BuildPath(InputFolder, "_Output")
strFileName = ""
' Check whether HL and SL folders exist
If Not (fso.FolderExists(fso.BuildPath(InputFolder, "HL")) And fso.FolderExists(fso.BuildPath(InputFolder, "SL"))) Then
MsgBox "Either HL or SL, or both folders don't exist!", vbOKOnly, "Warning"
GoTo endofsub
End If
' Check whether Output folder exist - create if not
If Not fso.FolderExists(OutputFolder) Then
Debug.Print OutputFolder & " doesn't exist"
fso.CreateFolder (OutputFolder)
End If
' Check if 2 HL reports exist in the HL folder
If Not Check_Folder("HL") Then GoTo endofsub
' Add a blank workbook, set to wb_destination and minimize it
Set wbDestination = Workbooks.Add
wbDestination.Windows(1).WindowState = xlMinimized
' Turn off stuff to speed up execution
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
' Get the reports for HL
Call Get_Reports("HL")
' Check if 2 SL reports exist in the SL folder, get the reports if so
If Check_Folder("SL") Then Call Get_Reports("SL")
' Delete the default sheet1 and save the STORE workbook
Application.DisplayAlerts = False
wbDestination.Sheets(1).Delete
wbDestination.Close Filename:=fso.BuildPath(OutputFolder, strFileName), SaveChanges:=True
Application.DisplayAlerts = True
' Clean-up set variables
Set wbDestination = Nothing
endofsub:
Set fso = Nothing
' Turn stuff back on
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Private Function Check_Folder(ByVal ReportType As String) As Boolean
Dim oFile As Object
CurrentFolder = fso.BuildPath(InputFolder, ReportType)
Check_Folder = True
If fso.GetFolder(CurrentFolder).Files.Count <> 2 Then
MsgBox "The " & ReportType & " folder doesn't have 2 files.", vbOKOnly, "Warning"
Check_Folder = False
Else
For Each oFile In fso.GetFolder(CurrentFolder).Files
' Check whether store names are same
If strFileName = "" Then
strFileName = Split(oFile.Name, "_IFRS_")(0)
Else
If strFileName <> Split(oFile.Name, "_IFRS_")(0) Then
MsgBox "Store name anomaly detected in folder " & ReportType, vbOKOnly, "Warning"
Check_Folder = False
End If
End If
' Check if file is an Excel file
If InStr("xlsx", fso.GetExtensionName(oFile.Path)) = 0 Then
MsgBox oFile.Name & " in " & ReportType & " folder is not an Excel file", vbOKOnly, "Warning"
Check_Folder = False
End If
' Check if file is a HL file
If InStr(oFile.Name, "_" & ReportType & "-") = 0 Then
MsgBox oFile.Name & " in " & ReportType & " folder is not an " & ReportType & " report", vbOKOnly, "Warning"
Check_Folder = False
End If
Next oFile
End If
End Function
Private Sub Get_Reports(ByVal ReportType As String)
'Debug.Print ReportType
Dim arr(1 To 4, 1 To 3) As Variant
' Populate the array
' arr(#,1) = Store Name
' arr(#,2) = Version Number
' arr(#,3) = 1 if latest, 0 if previous
Dim oFile As Object
Dim FileVersion As Variant
Dim InitialCounter As Integer
Dim Counter As Integer
InitialCounter = IIf(ReportType = "HL", 1, 3)
Counter = InitialCounter
For Each oFile In fso.GetFolder(CurrentFolder).Files
FileVersion = Split(oFile.Name, "-Ver")(1)
FileVersion = Val(Split(FileVersion, "_")(0))
arr(Counter, 1) = oFile.Name
arr(Counter, 2) = FileVersion
If strFileName = "" Then strFileName = Split(oFile.Name, "_IFRS_")(0)
Counter = Counter + 1
Next oFile
If arr(InitialCounter, 2) > arr(InitialCounter + 1, 2) Then
' First file is latest - arr(1,1)
arr(InitialCounter, 3) = 1
arr(InitialCounter + 1, 3) = 0
Else
' Second file is latest - arr(2,1)
arr(InitialCounter + 1, 3) = 1
arr(InitialCounter, 3) = 0
End If
Dim wbSource As Workbook
' Iterate folders and copy to destination
Dim i As Integer
For i = InitialCounter To InitialCounter + 1
' Open source file and set to wb_Source
Set wbSource = Workbooks.Open(fso.BuildPath(CurrentFolder, arr(i, 1)))
' Hide source file
wbSource.Windows(1).Visible = False
' Copy and rename the activesheet of source file
If arr(i, 3) = 1 Then
' file is latest
wbSource.ActiveSheet.Copy after:=wbDestination.Sheets(wbDestination.Sheets.Count)
wbDestination.ActiveSheet.Name = ReportType & "_Last_V"
Else
' file is previous
wbSource.ActiveSheet.Copy after:=wbDestination.Sheets(wbDestination.Sheets.Count)
wbDestination.ActiveSheet.Name = ReportType & "_Prev_V"
End If
' Close source file discarding any changes
wbSource.Close SaveChanges:=False
Next i
' Move HL_Last so it is always the first sheet
wbDestination.Sheets(ReportType & "_Last_V").Move Before:=wbDestination.Sheets(ReportType & "_Prev_V")
Set wbSource = Nothing
End Sub
