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
Bookmarks