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)运行“ShowDialog”模块，它将从单元格 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

现在这里是我尝试将我的代码与指南“结合”的位置和/方式:

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