VBA中合并循环的进度条

Question

我有一个合并宏，它可以打开、复制数据，并将数据从多个工作簿中的一个工作表粘贴到主工作表上，其中这些数据以及工作簿可能有数千个。总的来说，这个过程需要30分钟到一个小时，我认为进度条会有所帮助。

我在stackoverflow得到了用于合并部分的代码。这是一个有类似问题的人，然而，我在其他地方得到的进度条形码。为了满足我的需要，我不得不对代码进行各种修改。。在线示例使用for next循环代码作为进度条，而我的示例没有。

我试着运行我的代码，但进度条没有更新。。T_T

有人能帮我解决我的代码出了什么问题吗？非常感谢在这方面的任何帮助。。谢谢

Sub OpeningFiles()

Dim SelectedFiles As FileDialog
Dim NumFiles As Long, FileIndex As Long
Dim TargetBook As Workbook
Dim sName, sName2, sName3 As Range
Dim pctCompl As Single
Set sName = ThisWorkbook.Sheets("Sheet1").Range("j1")

Set SelectedFiles = Application.FileDialog(msoFileDialogOpen)
With SelectedFiles
.AllowMultiSelect = True
.Title = "Pick the files you'd like to consolidate:"
.ButtonName = ""
.Filters.Clear
.Filters.Add ".xlsx files", "*.xlsx"
.Show
End With

If SelectedFiles.SelectedItems.Count = 0 Then Exit Sub

NumFiles = SelectedFiles.SelectedItems.Count
For FileIndex = 1 To NumFiles
Set TargetBook = Workbooks.Open(SelectedFiles.SelectedItems(FileIndex), ReadOnly:=True)
Application.DisplayAlerts = False
ActiveWorkbook.Activate
Sheets(sName).Activate
On Error GoTo 0
Range("d11:j11").Select
            Range(Selection, Selection.End(xlDown)).Copy
ThisWorkbook.Sheets("Sheet1").Activate
Range("b2").Select
 Do
If IsEmpty(ActiveCell) = False Then
 ActiveCell.Offset(1, 0).Select
    End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.PasteSpecial Paste:=xlPasteValues

ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False


Next FileIndex
progress pctCompl
MsgBox ("Consolidation complete!")
End Sub
Sub progress(pctCompl As Single)
UserForm1.Text.Caption = pctCompl & "% Completed"
UserForm1.Bar.Width = pctCompl * 2
DoEvents
End Sub
Sub ShowProgress()
UserForm1.Show
End Sub

附录：

此代码

Sheets(sName).activate

选择打开的文件的页码，其中它始终是1-30之间的数字。现在，我必须一次指出一个数字。有没有办法做3到7次？就像一个循环？例如1-7或25-27。它总是升序的，所以我认为下面这样的代码可以工作吗？想法？

For sName = sNameStart To sNameEnd Step 1
Sheets(sName).Activate

On Error GoTo 0
Range("d11:j11").Select
            Range(Selection, Selection.End(xlDown)).Copy
ThisWorkbook.Sheets("Sheet1").Activate
Range("b2").Select
 Do
If IsEmpty(ActiveCell) = False Then
 ActiveCell.Offset(1, 0).Select
    End If
Loop Until IsEmpty(ActiveCell) = True
ActiveCell.PasteSpecial Paste:=xlPasteValues
ActiveWorkbook.Activate
Next sName

其中sName是图纸名称，sNameStart是起始图纸，sNameEnd是结束图纸。然而，当我启动此代码时，会出现此错误。。帮助

Answer 1

您需要在循环中将调用移动到progress pctCompl。

您发布的代码直到Next FileIndex 之后才调用progress pctCompl

ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False
Next FileIndex
progress pctCompl
MsgBox ("Consolidation complete!")

替换为：

ThisWorkbook.Application.CutCopyMode = False
TargetBook.Close SaveChanges:=False
'insert your command here
progress pctCompl
Next FileIndex

MsgBox ("Consolidation complete!")

Answer 2

如果您需要比进度条更精确的东西，请尝试放入：
Application.StatusBar = "File " & FileIndex & " of " & NumFiles
在For..Next循环中的某个地方，我喜欢它，因为它比进度条更详细
并且记得放
Application.StatusBar = False
循环后恢复标准状态栏。