Backup of Excel reports.

[bromy2004]

Hi,

i currently have a macro that goes though several folders, opens each spreadsheet and saves it as a .xlt to a location as well as .xls to another location.
the problem i'm having is its only going through 1 layer of folders.

• Folder 1
• Folder2
• Folder3
• Folder4

and Folder 2 might have another subfolder. this subfolder is ignored.
could i get some help modifying my macro please.

Option Explicit
Public FinalFileCount As Integer
Public Server_Letter As String
Public Forms As String
Public Start_Time As Double
Public Const ParentFolderPath As String = "Z:\Jet Reports\Reports\" 'Where the forms are saved
Sub Backup_All_Reports()
'''''''''''''''''''''''''''''''''''''''''
'Counts how many files there are to copy'
'''''''''''''''''''''''''''''''''''''''''
'Close Jet Reports add-in
On Error Resume Next
Workbooks("Jetreports.xlam").Close
Workbooks("Jetreports.xla").Close
On Error GoTo 0

Start_Time = Timer

'set the Quick Corporate Drive
Run "Server_Location_Mapping"

'Declarations
Forms = Server_Letter & "\ADMIN\Forms\"  'Forms Location
Dim FSO As Object 'File System Object
Dim FolderSubFolder As Object ' System Folder
Dim FolderFile As Object 'System File

'Progress Counter
Dim FileCount As Integer
FileCount = 0
FinalFileCount = 0
'Create File System Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'''''''''''''''''''
' Start File Count'
'''''''''''''''''''
For Each FolderSubFolder In FSO.GetFolder(ParentFolderPath).SubFolders
        For Each FolderFile In FSO.GetFolder(ParentFolderPath & FolderSubFolder.Name & "\").Files
            FinalFileCount = FinalFileCount + 1
        Next FolderFile
Next FolderSubFolder

If Format(Now, "HH:MM") > "19:00" Or Format(Now, "HH:MM") < "07:00" Then
    Exit Sub
    Else
        If MsgBox(Prompt:="Will copy " & FinalFileCount & " files from " & ParentFolderPath & vbNewLine & "To " & Forms, Buttons:=vbOKCancel, Title:="Copy Files") = vbCancel Then
            Run "Server_Location_Delete"
            Application.Windows(1).Close
            Exit Sub
            Else
            Progress_Bar.LabelProgress.Width = 0
            Progress_Bar.Show
        End If
End If
'''''''''''''''''''
' End File Count  '
'''''''''''''''''''

'Deletes the Server Mapping
Run "Server_Location_Delete"
End Sub

Sub JetProgress()
''''''''''''''''''''''''''''''''''''''''''''''''
' This actually Saves the copies of the reports'
''''''''''''''''''''''''''''''''''''''''''''''''
'Declarations
Dim CurrentFile As String
Dim NewFolder As String
Dim NewFileName As String
Dim FileType As String
Dim Ext As String
Dim Counter As Integer
Dim FSO As Object 'File System Object
Dim FolderSubFolder As Object ' System Folder
Dim FolderFile As Object 'System File
Dim NewFile As String
Dim PctDone As Single

'Progress Counter
Dim FileCount As Integer
FileCount = 0
'Create File System Object
Set FSO = CreateObject("Scripting.FileSystemObject")

'''''''''''''''
' Save As Code'
'''''''''''''''
FileCount = 1
    For Each FolderSubFolder In FSO.GetFolder(ParentFolderPath).SubFolders
            For Each FolderFile In FSO.GetFolder(ParentFolderPath & FolderSubFolder.Name & "\").Files
                CurrentFile = ParentFolderPath & FolderSubFolder.Name & "\" & FolderFile.Name

                Counter = 1
                Do While Counter <= 2
                    Select Case Counter
                        Case 1
                            Ext = ".xls"
                            NewFolder = "Backup_Forms\" & FolderSubFolder.Name
                            FileType = 56
                        Case 2
                            Ext = ".xlt"
                            NewFolder = FolderSubFolder.Name
                            FileType = 17
                        Case Else
                            MsgBox ("Error on Counter Select" & vbNewLine & "Counter = " & Counter)
                            Exit Sub
                    End Select

                'New File Name
                NewFileName = Replace(FolderFile.Name, ".xls", Ext)
        
                'New File Name and Location
                NewFile = Forms & NewFolder & "\" & NewFileName
                
                '''''''''''
                'Save Code'
                '''''''''''
                'Check if folder exists
                If Len(Dir(Forms & NewFolder, vbDirectory)) = 0 Then
                    Run "CreateFolders", Forms & NewFolder
                End If
                
                'Open File
                Application.Workbooks.Open (CurrentFile)
                'Dont Check Compatibility
                With Application.ActiveWorkbook
                    .CheckCompatibility = False
                    .UpdateLinks = xlUpdateLinksNever
                End With
                
                'calculation = Auto; Save
                Application.Calculation = 1
                Application.DisplayAlerts = False
                Application.ActiveWorkbook.SaveAs Filename:=NewFile, FileFormat:=FileType
                Application.DisplayAlerts = True
                Application.ActiveWorkbook.Close
                '''''''''''''''
                'End Save Code'
                '''''''''''''''
                '''''''''''''
                'Update Form'
                '''''''''''''
                PctDone = FileCount / (FinalFileCount * 2)
                With Progress_Bar
                        .FrameProgress.Caption = Format(PctDone, "0%")
                        .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
                        .File_Name.Caption = NewFileName
                        .Timer.Caption = Format(Timer - Time, "HH:MM:SS")
                End With
                DoEvents
                '''''''''''''''''
                'End Form Update'
                '''''''''''''''''
                FileCount = FileCount + 1
                Counter = Counter + 1
                Loop
            Next FolderFile
    Next FolderSubFolder
'''''''''''''''''''
' End Save As Code'
'''''''''''''''''''
Unload Progress_Bar
End Sub

Sub Server_Location_Mapping()
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'This Maps the Quick Corporate Drive to the first available Letter for Use'
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Array_Lett(25, 1)
Dim a As Integer

a = 0
Do Until a >= 26
    Array_Lett(a, 0) = Chr(a + 65)
        On Error Resume Next
        If Dir(Array_Lett(a, 0) & ":\") = "" Then
            'Check if Drive is CD Drive (Error 52 Complile Error)
            If Err.Number = 52 Then
                Err.Clear
                Else
                    Shell ("C:\WINDOWS\system32\cmd.exe /C NET USE " & Array_Lett(a, 0) & ": \\SERVER\ADMIN$")
                    Server_Letter = Array_Lett(a, 0) & ":"
                    Exit Sub
            End If
        End If
    a = a + 1
Loop
End Sub

Sub Time_Run()
Dim Hours As String
Dim Mins As String
Dim Secs As String
Dim HoursVal
Dim MinsVal
Dim SecsVal
HoursVal = (((Timer - Start_Time) / 60) / 60)
MinsVal = ((Timer - Start_Time) - ((Int(HoursVal) * 60) * 60)) / 60
SecsVal = (Timer - Start_Time) - (Int(MinsVal) * 60) - ((Int(HoursVal) * 60) * 60)

'Hours
Select Case Int(HoursVal)
    Case 1
    Hours = Int(HoursVal) & " Hour "
    Case 0
    Hours = ""
    Case Is > 1
    Hours = Int(HoursVal) & " Hours "
    Case Else
    Hours = Int(HoursVal) & " Hours& "
End Select
'Minutes
Select Case Int(MinsVal)
    Case 1
    Mins = Int(MinsVal) & " Minute "
    Case 0
    Mins = ""
    Case Is > 1
    Mins = Int(MinsVal) & " Minutes "
    Case Else
    Mins = Int(MinsVal) & " Minutes& "
End Select
'Seconds
Select Case Int(SecsVal)
    Case 1
    Secs = Int(SecsVal) & " Second"
    Case 0
    Secs = ""
    Case Is > 1
    Secs = Int(SecsVal) & " Seconds"
    Case Else
    Secs = Int(SecsVal) & " Seconds&"
End Select
MsgBox Prompt:="Elapsed Time " & Hours & Mins & Secs, Buttons:=vbInformation, Title:="Seconds"

End Sub

Sub Server_Location_Delete()
'''''''''''''''''''''''''''''''''
'This Deletes the Server Mapping'
'''''''''''''''''''''''''''''''''

Shell ("C:\WINDOWS\system32\cmd.exe /C NET USE " & Server_Letter & " /Delete")

End Sub

Sub CreateFolders(sfolderpath As String)
'''''''''''''''''''''''''''''''''''''''
' Creates Folder Structure for Reports'
'''''''''''''''''''''''''''''''''''''''

Dim sSubFolder As String
Dim sBaseFolder As String
Dim sTemp As String

Dim ArryDir
Dim i

ArryDir = Split(sfolderpath, "\")

For i = 0 To UBound(ArryDir) - 1
    sBaseFolder = sBaseFolder & ArryDir(i)
    sSubFolder = ArryDir(i + 1)
    'Make sure the base folder is ready to have a sub folder
    'tacked on to the end
    If Right(sBaseFolder, 1) <> "\" Then
        sBaseFolder = sBaseFolder & "\"
    End If
    
    'Make sure base folder exists
    If Len(Dir(sBaseFolder, vbDirectory)) > 0 Then
        'Replace illegal characters with an underscore
        sTemp = CleanFolderName(sSubFolder)
        'See if already exists
        If Len(Dir(sBaseFolder & sTemp, vbDirectory)) = 0 Then
            'Use MkDir to create the folder
            MkDir sBaseFolder & sTemp
        End If
    End If
Next
End Sub
Private Function CleanFolderName(ByVal sFolderName As String) As String
'''''''''''''''''''''''''''''''''''''''''''
'Cleans Dirty Characters from Folder Names'
'''''''''''''''''''''''''''''''''''''''''''
Dim i As Long
Dim sTemp As String

For i = 1 To Len(sFolderName)
    Select Case Mid$(sFolderName, i, 1)
        Case "/", "\", ":", "*", "?", "", "|"
        sTemp = sTemp & "_"
        MsgBox ("Error" & vbNewLine & sFolderName & vbNewLine & sTemp)
        Case Else
        sTemp = sTemp & Mid$(sFolderName, i, 1)
    End Select
Next i
CleanFolderName = sTemp
End Function

the userform has

Private Sub UserForm_Activate()
    Run ("JetProgress")
End Sub

Private Sub UserForm_Terminate()
'Run the time counter
Run "Time_Run"
End Sub

i eventually want an indefinite loop, so if there are levels of subfolders, it should go through every one.

thanks in advance for the help.

-Bromy