我想知道是否有人可以帮助我。
我正在尝试整理一个脚本，该脚本会生成一个“Splash”屏幕，而正在运行一个很长的Excel宏。
我对此做了大量研究，并找到了一个例子here。
我已经使用以下代码在其属性中设置了我的表单：
' 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
然后我创建了一个包含这段代码的模块：
现已删除工作代码
我遇到的问题是，我真的不确定如何在显示表单时将其与我想要运行的宏集成。
下面的代码是我将要运行的宏：
更新的代码 - 工作脚本
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
我只是想知道是否有人可能会看到这个，并就如何整合这两者提供一些指导。
非常感谢和问候
答案 0 :(得分：3)
您需要替换此部分代码：
' 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
...使用长时间运行的代码并在代码中包含frm.prgStatus.Value = i（或类似代码）以更新进度条。
如果你打电话给你的sub并且它在另一个模块中，它将无法直接访问更新进度条。一种选择是将进度条对象作为参数传递给子，如下所示：
Public Sub CreateAllData(byref MyProgBar As ProgressBar)
在您的sub中，您可以通过执行以下操作来更新进度条：
MyProgBar.Value = 1
你会像这样打电话给你的潜水员：
CreateAllData frm.prgStatus