VBA Splash Screen As Macro Runs

Hi, I wonder whether someone may be able to help me please.

I'm trying to put together a 'Splash Screen' which is visible to the user as a rather long macro runs.

I've done quite a bit of research and found a suitable example here: http://www.vb-helper.com/howto_excel_show_splash.html.

I've created a general module and inserted the following code:

Sub ShowSplash()
Dim frm As frmSplash
Dim i As Integer
Dim j As Integer

    ' Deactivate the keyboard.
    Application.OnKey "^d", "KeyboardOn"
    Application.DataEntryMode = True

    ' Display the splash form non-modally.
    Set frm = New frmSplash
    frm.TaskDone = False
    frm.prgStatus.Value = 0
    frm.Show False

    ' Perform the long task.
    For i = 0 To 100 Step 10
        frm.prgStatus.Value = i

        ' Waste some time.
        For j = 1 To 1000
            DoEvents
        Next j
    Next i

    ' Close the splash form.
    frm.TaskDone = True
    Unload frm

    ' Re-activate the keyboard.
    Application.DataEntryMode = False
End Sub

Then inserted the following code to the user form:

' Set true when the long task is done.
Public TaskDone As Boolean

Private Sub UserForm_QueryClose(Cancel As Integer, _
    CloseMode As Integer)
    Cancel = Not TaskDone
End Sub

I've run the user form in isolation and this works as expected, but I'm having a little difficulty in getting this to run whilst my macro runs.

The code below is the macro which I'm wanting to run whilst the form is visible, then once finished allow the form to fade out:

Sub CreateAllData()
    
    Dim cell As Range
    Dim cll As Range
    Dim DestWB As Workbook
    Dim dR As Long
    Dim excelfile As Variant
    Dim Fd As FileDialog
    Dim i As Long
    Dim LastRow As Long
    Dim LR As Long
    Dim MidFile As String
    Dim MyNames As Variant
    Dim sFile As String
    Dim sMidFile As Variant
    Dim SourceSheet As String
    Dim StartRow As Long
    Dim wb As Workbook
    Dim ws As Worksheet

    Set DestWB = ActiveWorkbook

    SourceSheet = "Input"
    StartRow = 2

    sMidFile = "January, February, March, April, May, June, July, August, September, October, November, December"

    MidFile = InputBox("Enter Folder Name e.g. 'January'", "Managers Data")
    If InStr(sMidFile, MidFile) = 0 Or MidFile = "" Then
        MsgBox "A valid month name was not entered"
        End
    End If

    Application.ScreenUpdating = False

    Set Ash = ActiveSheet
    Set newsht = Worksheets.Add(After:=Worksheets(1))
    newsht.Name = "All Data"

    With newsht
        With .Range("B5")
            .Value = "All Data"
            .Offset(2, 0).Resize(, 5).Value = Array("Resource LOB", "Staff Name", "Job Role", "Project Name", "Project ID")
        End With
        .Range("G7").Formula = "=B3"
        .Range("H7").Resize(, 13).Formula = "=EOMONTH(G7,0)+1"
        With Range("U7")
            .Value = "Flexible Resource"
            .Offset(, 1).Value = "Line Manager"
            .Offset(, 2).Value = "Date of Termination"
        End With
    End With

    Range("B7:W7").Select
    Selection.AutoFilter

    sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\Resource Activity By Month\"
    excelfile = Dir(sFile & "*.xls")
    Do While excelfile <> ""

        Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
        For Each ws In wb.Worksheets
            If ws.Name = SourceSheet Then
                With ws
                    If .UsedRange.Cells.Count > 1 Then
                        dR = DestWB.Worksheets("All Data").Range("B" & DestWB.Worksheets("All Data").Rows.Count).End(xlUp).Row + 1
                        If dR < 8 Then dR = 7  'destination start row
                        LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                        If LastRow >= StartRow Then
                            .Range("A" & StartRow & ":R" & LastRow).Copy
                            DestWB.Worksheets("All Data").Cells(dR, "C").PasteSpecial xlValues
                            DestWB.Worksheets("All Data").Range("B8:W" & LastRow).Font.Name = "Lucida Sans"
                            DestWB.Worksheets("All Data").Range("B8:W" & LastRow).Font.Size = 10
                        End If
                    End If
                End With
                Exit For
            End If
            Next ws
            wb.Close savechanges:=False
            excelfile = Dir
        Loop

        Set Ash = ActiveSheet
        Set newsht = Worksheets.Add(After:=Worksheets(2))
        newsht.Name = "Resources List"

        With newsht
            With .Range("B5")
                .Value = "Resources List"
                .Offset(2, 0).Resize(, 6).Value = Array("Resource LOB", "Staff Name", "Job Role", "Flexible Resource", "Line Manager", "Date of Termination")
            End With
        End With

        Range("B7:G7").Select
        Selection.AutoFilter

        sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\Resources List\"
        excelfile = Dir(sFile & "*.xls")
        Do While excelfile <> ""

            Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
            For Each ws In wb.Worksheets
                If ws.Name = SourceSheet Then
                    With ws
                        If .UsedRange.Cells.Count > 1 Then
                            dR = DestWB.Worksheets("Resources List").Range("B" & DestWB.Worksheets("Resources List").Rows.Count).End(xlUp).Row + 1
                            If dR < 8 Then dR = 7  'destination start row
                            LastRow = .Range("A" & Rows.Count).End(xlUp).Row
                            If LastRow >= StartRow Then
                                .Range("A" & StartRow & ":F" & LastRow).Copy
                                DestWB.Worksheets("Resources List").Cells(dR, "B").PasteSpecial xlValues
                                DestWB.Worksheets("Resources List").Range("B8:G" & LastRow).Font.Name = "Lucida Sans"
                                DestWB.Worksheets("Resources List").Range("B8:G" & LastRow).Font.Size = 10
                            End If
                        End If
                    End With
                    Exit For
                End If
                Next ws
                wb.Close savechanges:=False
                excelfile = Dir
            Loop

            Call AdditionalData
            Call ResourcesListFormat
            Call AllDataFormat
            Call CreateUniques
            Call UniqueRecordsExtract
            Call UniqueRecordsFormat
            Call CreateSheets
            Call ApplySubtotalsandDelete

            Sheets("Macros").Select
            Application.ScreenUpdating = True
        End Sub

I've been trying to get this to work for a few days now, sadly without any success, so I just wondered whether someone could possibly look at this please and offer some guidance on how I may integrate the two.

Many thanks and kind regards

Hi @Izandol, thank you very much for taking the time to reply to my post and for putting the solution together, I really appreciate it.

The form works fine as does the progress bar. The only item which I can't display is the label which tells the user what is happening which seems a little strange, but I'm sure I'll be able to work it out.

All the best and kind regards