With UserForm1

        .LabPct1.Caption = Pct * 100 & " %": DoEvents  '顯示百分比

        .LabProg21.Width = Pct * (.LabProgressBar2.Width - j)

        intPctColor = CInt((Pct * 255) * 0.75)  '紅色色系

        lngColor = RGB(64 + intPctColor, 0, 0)

        .LabProg21.BackColor = lngColor: DoEvents  '顯示進度條背景色

        DoEvents

        .Repaint

    End With

End Sub

Dim strText1 As String

Dim intI, i As Integer

Private Sub UserForm_activate()

    Me.Label1 = "程式執行中"

    Me.LabProg21.Width = 0        '清除Type 2進度條方塊

    Me.LabPct1.Visible = True

    j = (Me.LabProg21.Left - Me.LabProgressBar2.Left) * 2

    With Application

        .EnableEvents = False

        .ScreenUpdating = False  '關閉復螢幕更新

    End With

    strText1 = Sheets("LL").ComboBox1.Text

    For i = 5 To 26

        rng(i).Copy Destination:=Sheets("LL").Cells(i, 2)

        K = K + 1

        DcPct = K / ((26 - 5) + 1) '進度百分比

        Call UpdateProgress(DcPct)   '更新進度條百分比

    Next i

    Worksheets("SJ").Cells.AutoFilter   '關閉篩選

    With Application

        .EnableEvents = True

        .ScreenUpdating = True   '開啟螢幕更新

    End With

    Sleep 1000   '1秒

    Unload Me

End Sub

Function rng(i) As Range

    With Worksheets("SJ")

        ctxt = Worksheets("LL").Cells(i, 1)

        '篩選公司

        .Cells.AutoFilter Field:=2, Criteria1:=ctxt

        strText1 = Sheets("LL").ComboBox1.Text

        '篩選月份

        .Cells.AutoFilter Field:=1, Criteria1:=strText1

        '指定範圍

        Set rng = .Range("C2:W" & .[A65536].End(xlUp).Row). _

            SpecialCells(xlCellTypeVisible)

    End With

End Function