VBA中合并循环的进度条

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

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

我尝试运行我的代码，但进度条不更新。。图特

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

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

选择打开的文件的sheetname，其中它始终是1-30之间的数字。现在，我必须一次指出第一个。有没有办法做到3次或7次？像一个环？e、 g 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是结束工作表。

---

但是，我在启动此代码时遇到此错误。。帮助？

如果您需要比进度条更精确的内容，请尝试放置：

Application.StatusBar=“File”&FileIndex&“of”&NumFiles

在

For..Next

循环中的某个地方，我喜欢这个，因为它比进度条更详细。
并且记得把

Application.StatusBar=False

---

在循环后恢复标准状态栏。

您需要将调用移动到循环内的

progress pctCompl

您发布的代码在下一个文件索引之后才会调用

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!")

---

UserForm1.show vbModeless

您需要更新

pctCompl

的值，并在

中的某个地方调用
progress
以获得
loopperfect！是啊，这好多了！我能够根据您的建议以及马克·菲茨杰拉德的回答，提出一些见解，以获得进度条。。多谢各位！