VBA - 宏执行时显示进度条

Question

我有一个宏，可以一次打开一个文件夹中的xlsx文件，并将其工作表复制到特定文件中。有时这个宏需要相当长的时间来运行，我想添加一个进度条来向用户显示宏的距离。

我找到了一些指南，说明如何执行此操作，并在示例工作簿中对其进行了测试。现在，我正在尝试将指南与我的宏集成，但我没有取得任何成功。

这是我的代码（复制表格）：

Sub ImportDataSheets()

    Dim X As Workbook
    Set X = Workbooks("3rd Party.xlsm")

    path = "X:\Test\3rd Party\\"
    Filename = Dir(path & "*.xlsx")

    Do While Filename <> ""
        Workbooks.Open Filename:=path & Filename, ReadOnly:=True

        For Each Sheet In ActiveWorkbook.Sheets

            Sheet.Copy After:=X.Sheets(1)

        Next Sheet

        Workbooks(Filename).Close
        Filename = Dir()

    Loop

End Sub

以下是使用表单作为进度条的指南的链接：

http://spreadsheetpage.com/index.php/tip/displaying_a_progress_indicator/

以下是该指南的基本细目：

1）插入表单并使其如下所示：

在表单内添加了一个框架（重命名为FrameProgress），并在框架内添加了一个标签（重命名为LabelProgress）

2）右键单击表单并单击视图代码

3）在窗口内，添加以下代码：

Private Sub UserForm_activate()
    Call Main
End Sub

4）插入模块并添加以下代码：

Sub Main()
'   Inserts random numbers on the active worksheet
    Dim Counter As Integer
    Dim RowMax As Integer, ColMax As Integer
    Dim r As Integer, c As Integer
    Dim PctDone As Single

    If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub
    Cells.Clear
    Application.ScreenUpdating = False
    Counter = 1
    RowMax = 100
    ColMax = 25
    For r = 1 To RowMax
        For c = 1 To ColMax
            Cells(r, c) = Int(Rnd * 1000)
            Counter = Counter + 1
        Next c
        PctDone = Counter / (RowMax * ColMax)
        With UserForm1
            .FrameProgress.Caption = Format(PctDone, "0%")
            .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
        End With
'       The DoEvents statement is responsible for the form updating
        DoEvents
    Next r
    Unload UserForm1
End Sub

5）插入模块并添加以下代码：

Sub ShowDialog()
    UserForm1.LabelProgress.Width = 0
    UserForm1.Show
End Sub

6）运行＆＃34; ShowDialog＆＃34;模块，它将从单元格A1 - 单元格Y100填充数据并显示进度条 - 这样做100％

我注意到在上面的代码中，有一个计数器和该计数器用于除以行和列数组合得到百分比，所以我得到下面的代码来计算文件夹，以便我有一个计数器值 - 并在每个文件关闭后，第二个计数变量将增加1。

这是我获得计数器代码的地方：

count files in specific folder and display the number into 1 cel

代码：

Sub sample()

    Dim FolderPath As String, path As String, count As Integer
    FolderPath = "X:\Test\3rd Party"

    path = FolderPath & "\*.xlsx"

    Filename = Dir(path)

    Do While Filename <> ""
       count = count + 1
        Filename = Dir()
    Loop

    Range("Q8").Value = count
    'MsgBox count & " : files found in folder"
End Sub

现在这里是我和/或如何尝试＆＃34;结合＆＃34;我的代码与指南：

1）这就是我的表单中的代码：

Sub UserForm_activate()
    Call testing
End Sub

2）这就是我的子看起来像：

Sub testing()

    Dim FolderPath As String, path As String, count As Integer
    Dim PctDone As Single
    Dim Counter As Integer
    FolderPath = "X:\Test\3rd Party"

    path = FolderPath & "\*.xlsx"

    Dim X As Workbook
    Set X = Workbooks("3rd Party.xlsm")

    Counter = 1

    Filename = Dir(path)

    For r = 1 To count

        Do While Filename <> ""

            Workbooks.Open Filename:=path & Filename, ReadOnly:=True

            For Each Sheet In ActiveWorkbook.Sheets

                Sheet.Copy After:=X.Sheets(1)

                Workbooks(Filename).Close

                Filename = Dir()

            Next Sheet

            count = count + 1

        Loop

        PctDone = Counter / count

        With UserForm1

            .FrameProgress.Caption = Format(PctDone, "0%")
            .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)

        End With

        DoEvents

    Next r

    Unload UserForm1

End Sub

我有很多宏，将它用于需要很长时间执行的宏会很棒，所以我希望如果我让它与它一起使用，我可以将它们全部用在它们身上。

Answer 1

希望有所帮助......

修改： 我在每个循环的外面移动了一行：

   Workbooks(strFile).Activate
   ActiveWorkbook.Close SaveChanges:=False

代码：

 Sub testing()

    Application.ScreenUpdating = False
    Dim path As String, count As Integer
    Dim PctDone As Single
    Dim Counter As Integer
    count = 0

    Dim wkbk As Workbook
    Set wkbk = Workbooks("3rd Party.xlsm")

    'Change this to your folder path
    path = "X:\Test\3rd Party\"
    strFile = Dir(path & "*.xlsx")

    'This loop counts the number of files in my folder
    Do While Len(strFile) > 0
        count = count + 1
        strFile = Dir
    Loop

    strFile = Dir(path & "\*.xlsx")
    ' This loop will go through the folder and open each file and close it
    Do While Len(strFile) > 0

        Workbooks.Open Filename:=path & "\" & strFile, ReadOnly:=False
        Workbooks(strFile).Activate
        ''''' Do what you want Here '''''

        For Each Sheet In ActiveWorkbook.Sheets

            Sheet.Copy After:=wkbk.Sheets(1)

        Next Sheet

        Workbooks(strFile).Activate
        ActiveWorkbook.Close SaveChanges:=False

        'Every time it opens a file and close it, the counter will increment by one
        Counter = Counter + 1

        'The progress bar will be updated each time a new file is opened
        PctDone = Counter / count
        With UserForm1
            .FrameProgress.Caption = Format(PctDone, "0%")
            .LabelProgress.Width = PctDone * (.FrameProgress.Width - 10)
        End With

        DoEvents

        'Go to the next file in the folder
        strFile = Dir
    Loop
    Application.ScreenUpdating = True

    Unload UserForm1

End Sub

Answer 2

使用我在this post中提供的进度条示例。

注意模块最顶端的 Option Explicit ....我不能强调这是多么重要。它会强制您在使用之前声明每个变量。

Option Explicit

Sub ImportDataSheets()

    Dim X As Workbook
    Dim Src_Book As Workbook
    Dim FileCount As Long

    Dim Path As String
    Dim FileName As String
    Dim Sheet As Worksheet

    Dim lCurrentCount As Long

    Set X = Workbooks("3rd Party.xlsm")

    Path = "X:\Test\3rd Party\\"
    FileName = Dir(Path & "*.xlsx")

    'This will count all files in the folder.
    FileCount = CreateObject("Scripting.FileSystemObject").GetFolder(Path).Files.Count

    Do While FileName <> ""
        Set Src_Book = Workbooks.Open(FileName:=Path & FileName, ReadOnly:=True)

        For Each Sheet In Src_Book.Sheets
            Sheet.Copy After:=X.Sheets(1)
        Next Sheet

        'This is where the progress bar gets updated.  
        'You'll need something to update the lCurrentCount for each book.
        UpdateProgressBar lCurrentCount, lFinalCount

        Src_Book.Close
        FileName = Dir()
    Loop

End Sub  

您可以将UpdateProgressBar lCurrentCount, lFinalCount更改为UpdateProgressBar lCurrentCount, lFinalCount, Src_Book.Name，以便进度条显示正在打开的图书的名称。