VBA Splash Screen - excel

Question

I wonder whether someone may be able to help me please.
I'm trying to put together a script which produces a "Splash" screen whilst a a lengthy Excel macro is being run.
I've done quite a bit of research on this and found an example here.
I've set up my form with the following code in it's properties:
' 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 then created a module which contains this piece of code:
Now Removed in Working Code
The problem I have is that I'm really unsure how to integrate this with the macro I want to run whilst the form is displayed.
The code below is the macro I'll be running:
Updated Code - Working Script
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
Dim frm As frmSplash
Dim j As Integer
' Display the splash form non-modally.
Set frm = New frmSplash
frm.TaskDone = False
frm.prgStatus.Value = 0
frm.Show False
For j = 1 To 1000
DoEvents
Next j
Set DestWB = ActiveWorkbook
SourceSheet = "Input"
StartRow = 2
sMidFile = "January, February, March, April, May, June, July, August, September, October, November, December"
MidFile = InputBox("Enter the name of the monthly folder e.g. 'January'", "All Time Recording 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(, 14).Value = Array("Project LOB", "Resource LOB", "Staff Name", "Task", "Project Name", "Project Code", "Project ID", "Job Role", "Month", "Forecast Hrs", "Forecast FTE", "Actuals Hrs", "Actuals FTE", "Flexible Resource")
End With
End With
Range("B7:O7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Data\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
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 & ":M" & LastRow).Copy
DestWB.Worksheets("All Data").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Data").Range("B8:N" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Data").Range("B8:N" & LastRow).Font.Size = 10
DestWB.Worksheets("All Data").Range("K8:N" & LastRow).NumberFormat = "#,##0.00"
DestWB.Worksheets("All Data").Range("K8:N" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 10
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(2))
newsht.Name = "All Projects"
With newsht
With .Range("B5")
.Value = "All Projects"
.Offset(2, 0).Resize(, 7).Value = Array("Project LOB", "Project Name", "Project Code", "Project ID", "Project Priority", "Project Start Date", "Project Finish Date")
End With
End With
Range("B7:H7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Projects\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("All Projects").Range("B" & DestWB.Worksheets("All Projects").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 & ":G" & LastRow).Copy
DestWB.Worksheets("All Projects").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Projects").Range("B8:H" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Projects").Range("B8:H" & LastRow).Font.Size = 10
DestWB.Worksheets("All Projects").Range("H8:H" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 20
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(3))
newsht.Name = "All Resources"
With newsht
With .Range("B5")
.Value = "All Resources"
.Offset(2, 0).Resize(, 8).Value = Array("Staff Name", "Resource LOB", "Job Role", "Month", "Staff FTE", "Flexible Resource", "Line Manager", "Date of Termination")
End With
End With
Range("B7:I7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\All Resources\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("All Resources").Range("B" & DestWB.Worksheets("All Resources").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 & ":E" & LastRow).Copy
DestWB.Worksheets("All Resources").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("All Resources").Range("B8:I" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("All Resources").Range("B8:I" & LastRow).Font.Size = 10
DestWB.Worksheets("All Resources").Range("F8:H" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 30
Set sht = Sheets("All Resources")
MyNames = Array("AllResSName", "AllResLOB", "AllResJRole", "AllResPeriod", "AllResFTE", "AllResFlex", "AllResLineM", "AllResTerm")
i = 0
LR = sht.Range("B" & Rows.Count).End(xlUp).Row
For Each cll In Ash.Range("B8:I8").Cells
Range(sht.Cells(8, cll.Column), sht.Cells(LR, cll.Column)).Name = MyNames(i)
i = i + 1
Next cll
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(4))
newsht.Name = "Flexible Resources List"
With newsht
With .Range("B5")
.Value = "Flexible Resources List"
.Offset(2, 0).Resize(, 6).Value = Array("Resource LOB", "Staff Name", "Grade", "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 & "\Flexible Resources\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("Flexible Resources List").Range("B" & DestWB.Worksheets("Flexible 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 & ":G" & LastRow).Copy
DestWB.Worksheets("Flexible Resources List").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("Flexible Resources List").Range("B8:G" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("Flexible 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
frm.prgStatus.Value = 40
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(5))
newsht.Name = "IDEAS"
With newsht
With .Range("B5")
.Offset(2, 0).Resize(, 5).Value = Array("Staff Name", "Project Name", "Project ID", "Month", "Actuals FTE")
End With
End With
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\HUB\IDEAS\"
excelfile = Dir(sFile & "*.xls")
Do While excelfile <> ""
Set wb = Workbooks.Open(Filename:=sFile & excelfile, ReadOnly:=True, Password:="master")
For Each ws In wb.Worksheets
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("IDEAS").Range("B" & DestWB.Worksheets("IDEAS").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 & ":E" & LastRow).Copy
DestWB.Worksheets("IDEAS").Cells(dR, "B").PasteSpecial xlValues
DestWB.Worksheets("IDEAS").Range("B8:F" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("IDEAS").Range("B8:F" & LastRow).Font.Size = 10
DestWB.Worksheets("IDEAS").Range("F8:F" & LastRow).HorizontalAlignment = xlCenter
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 50
Set Ash = ActiveSheet
Set newsht = Worksheets.Add(After:=Worksheets(6))
newsht.Name = "Profile Data"
With newsht
With .Range("B5")
.Value = "Flexible Resource Profile Data"
.Offset(2, 0).Resize(, 4).Value = Array("Resource LOB", "Staff Name", "Project Name", "Job Role")
End With
.Range("F7").Formula = "=B3"
.Range("G7").Resize(, 13).Formula = "=EOMONTH(F7,0)+1"
With Range("T7")
.Value = "Flexible Resource"
.Offset(, 1).Value = "Line Manager"
.Offset(, 2).Value = "Date of Termination"
End With
End With
Range("B7:V7").Select
Selection.AutoFilter
sFile = "\\Irf02200\ims r and d management\D&RM\Reporting\Clarity Extracts\" & MidFile & "\Managers 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
Call ShowProgress
If ws.Name = SourceSheet Then
With ws
If .UsedRange.Cells.Count > 1 Then
dR = DestWB.Worksheets("Profile Data").Range("B" & DestWB.Worksheets("Profile 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 & ":Q" & LastRow).Copy
DestWB.Worksheets("Profile Data").Cells(dR, "C").PasteSpecial xlValues
DestWB.Worksheets("Profile Data").Range("B8:V" & LastRow).Font.Name = "Lucida Sans"
DestWB.Worksheets("Profile Data").Range("B8:V" & LastRow).Font.Size = 10
DestWB.Worksheets("Profile Data").Range("F8:S" & LastRow).NumberFormat = "#,##0.00"
End If
End If
End With
Exit For
End If
Next ws
wb.Close savechanges:=False
excelfile = Dir
Loop
frm.prgStatus.Value = 60
Call AllDataSignals
Call AllResourcesSignals
Call IDEASFormat
Call DeleteBlankRowsCopy
Call AllDataFormat
Call AllProjectsFormat
Call AllResourcesFormat
Call FlexibleResourcesListFormat
frm.prgStatus.Value = 100
' Close the splash form.
frm.TaskDone = True
Unload frm
Sheets("Macros").Select
Application.ScreenUpdating = True
End Sub
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 regards

Answer 1

You need to replace this portion of the code:
' 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
...with your long running code and include the frm.prgStatus.Value = i (or similar) in your code to update the progress bar.
EDIT
If you call your sub from and it is in another module, it will not have direct access to update the progress bar. One option is to pass in the progress bar object as a parameter to your sub, like this:
Public Sub CreateAllData(byref MyProgBar As ProgressBar)
Within your sub, you would update the progress bar by doing something like this:
MyProgBar.Value = 1
You will call your sub like this:
CreateAllData frm.prgStatus