Barra de Progresso VBA

[FSoares.FCS]

Bom dia, 

Queria saber se a possibilidade de colocar barra de progresso ou outra coisa que ao iniciar a UserForm e clicar no botão "SIM", que fique identificando que a um processamento e o usuário não pense que o excel travou, sendo que a UserForm tem varias opções de funções, os que eu achei na internet trava o processamento...

As funções demora alguns minutos.

Desde já agradeço a ajuda.

Anexei só duas funções que UserForm usar, pois tem mais e fica muito extensão aqui:

Sub TBCUSTO()

On Error GoTo Erro
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim resposta

resposta = MsgBox("Deseja iniciar a separação dos centros de custos ...? ", vbYesNo)
If resposta = vbNo Then
    Exit Sub
 End If

     'Definr Planilhas
        Set B = Plan6 'Balancete
        Set W = Plan2 'C.custo
            W.Select
            W.Range("C2").Select
            pula_aba = W.Range("C2")
        Set Y = Sheets(pula_aba)
            Y.Select
            Y.Range("A1").Select
            aba = ActiveSheet.Name
'Estrutura de Repetição
Do While W.Range("C2") <> " "
       'Limpar planilha e Procura centro de custo
     W.Select
     
        retorno = Application.WorksheetFunction.VLookup(aba, W.Columns("D:D"), 1, False)
                W.Range("A2") = retorno
                Y.Select
                Cells.Select
                  'Range("A:K").Select
                 Selection.Delete Shift:=xlUp
                'Selection.ClearContents
  'Filtrando pelo filtro avançado
    Range("A1").Select
    B.Columns("A:G").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=W.Range("A1:A2"), CopyToRange:=Range("A1"), _
        Unique:=False
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    
    SomaValor
    
       W.Select
            ActiveCell.Offset(1, 0).Select
               pula_aba = ActiveCell.Value
  If ActiveCell.Value = "" Then
    Exit Do
       End If
    
             Set Y = Sheets(pula_aba)
                 Y.Select
                 Y.Range("A1").Select
                 aba = ActiveSheet.Name
  Loop
    
    ActiveWorkbook.Save

Erro:
MsgBox (" Chegou ao último Centro de Custo... ( " & pula_aba & " ) - Se não erro no nome da Aba !!")
MsgBox ("Fim do Processo... Tenha um ótimo dia....")
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub
Sub RAZAO_CUSTO()

On Error GoTo Erro
Application.DisplayAlerts = False
Application.ScreenUpdating = False

Dim resposta

resposta = MsgBox("Deseja iniciar a separação dos centros de custos ...? ", vbYesNo)
If resposta = vbNo Then
    Exit Sub
 End If

     'Definir Planilhas
        Set B = Plan229     'Razão
        Set W = Plan2       'C.Custo
            W.Select
            W.Range("C2").Select
            pula_aba = W.Range("C2")
        Set Y = Sheets(pula_aba)
            Y.Select
            Y.Range("A1").Select
            aba = ActiveSheet.Name

'Estrutura de Repetição
Do While W.Range("C2") <> " "
       
       'Limpar planilha e Procura centro de custo
     W.Select
     
        retorno = Application.WorksheetFunction.VLookup(aba, W.Columns("D:D"), 1, False)
                W.Range("A2") = retorno
                Y.Select
                 Cells.Select
                  Selection.Delete Shift:=xlUp
                
  'Filtrando pelo filtro avançado
    Range("A1").Select
    B.Columns("A:M").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=W.Range("A1:A2"), CopyToRange:=Range("A1"), _
        Unique:=False
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("A1").Select
    
    If Range("B3") <> "" Then
         'Subtotais
    Range("A1").Select
    Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(8, 9, 10) _
        , Replace:=True, PageBreaks:=False, SummaryBelowData:=True
    ActiveSheet.Outline.ShowLevels RowLevels:=2
    Range("A1").Select
    Else
    End If
    'Ajuste do Cabeçario
   ActiveWindow.SmallScroll ToRight:=-1
    Range("A1:K1").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlDouble
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlDouble
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlDouble
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlDouble
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    With Selection.Font
        .Name = "Cambria"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMajor
    End With
    With Selection.Font
        .Name = "Calibri"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Selection.Font.Bold = True
    Columns("F:F").ColumnWidth = 3.57
    Columns("E:E").ColumnWidth = 3
    Columns("G:G").ColumnWidth = 31.86
    Columns("I:K").Select
    Columns("I:K").EntireColumn.AutoFit
    Columns("B:B").ColumnWidth = 37.14
    ActiveWindow.SmallScroll ToRight:=-1
    Columns("A:A").ColumnWidth = 3.71
    Columns("A:A").ColumnWidth = 1
   ' Columns("C:C").Select
    'Selection.Font.Bold = False
    'Selection.Font.Bold = True
    Columns("C:C").Select
    Selection.Font.Bold = False
    Selection.Font.Bold = True
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
    Range("C1").Select
    With Selection.Font
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
    End With
    Range("A1:K1").Select
   
   W.Select
            
            ActiveCell.Offset(1, 0).Select
               pula_aba = ActiveCell.Value
  If ActiveCell.Value = "" Then
    Exit Do
       End If
            Set Y = Sheets(pula_aba)
                 Y.Select
                 Y.Range("A1").Select
                 aba = ActiveSheet.Name
   Loop
    ActiveWorkbook.Save

Erro:
MsgBox (" Chegou ao último Centro de Custo... ( " & pula_aba & " ) - Se não erro no nome da Aba !!")

MsgBox "Fim do Processo... Tenha um ótimo dia...."

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub