Question

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

我在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

选择已打开文件的工作表名称，其中始终为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

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

Answer 2

您需要将呼叫转移到循环内的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!")

VBA中合并循环的进度条

2 个答案: