VBA中的合并循环的进度条

Question

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

我得到了用于整合部分的代码，这里是在stackoverflow。这是一个有类似问题的人，但是，我得到了其他地方的进度条码。为了满足我的需要，我不得不为了满足我的需要而对代码进行评估。在线示例使用了一个用于进度条的下一个循环代码。

我试图运行我的代码，但进度条不更新... 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 

选择打开文件的SHEETNAME其中它总是从一些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。

您发布不叫progress pctCompl后才Next FileIndex

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
你的循环后恢复标准状态栏。