Meus Caros, Bom Dia!
Tenho uma macro que apura o resultado de vendas de algumas redes, e salva em novos arquivos, mais como a quantidade de redes e filiais são grandes, a macro esta um pouco demorada, então gostria de incluir uma barra de Progresso na barra de status para identificar o tempo que resta de atualização.
Já vi alguns exemplos na internet, mais não consigo incluir no meu script por causa do LOOP. Alguem poderia me dar uma luz?
Segue abaixo meu script:
Sub EXECUTAR()
Dim MyArray() As Variant
Sheets("Redes").Select
Range("C3").Select
Do While IsEmpty(ActiveCell) = False 'Enquanto estiver celula vazia
Selection.Copy
Sheets("CAPA").Select
Range("D10").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Application.ScreenUpdating = False 'Ocultar a macro na tela do excel
Application.DisplayAlerts = False 'Dar sim automaticamente nos alertas
Workbooks.Add
ActiveWorkbook.SaveAs Filename:= _
"C:Usersallison.silvaDesktopMovimentações Diarias20147 - JUL7.07_18.07flash.xls" _
, FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.ScreenUpdating = False 'Ocultar a macro na tela do excel
Application.DisplayAlerts = False 'Dar sim automaticamente nos alertas
'Filial AM
Windows("Gerar Capas de Mídias V2.xlsm").Activate
Sheets("AM").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("AM").Select
Sheets("AM").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial AL
Sheets("AL").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("AL").Select
Sheets("AL").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial BA
Sheets("BA").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("BA").Select
Sheets("BA").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial BH
Sheets("BH").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("BH").Select
Sheets("BH").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial CE
Sheets("CE").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("CE").Select
Sheets("CE").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial ES
Sheets("ES").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("ES").Select
Sheets("ES").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial GO
Sheets("GO").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("GO").Select
Sheets("GO").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial MT
Sheets("MT").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("MT").Select
Sheets("MT").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial PR
Sheets("PR").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("PR").Select
Sheets("PR").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial RJ
Sheets("RJ").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("RJ").Select
Sheets("RJ").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial RF
Sheets("RF").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("RF").Select
Sheets("RF").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial RS
Sheets("RS").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("RS").Select
Sheets("RS").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
'Filial SP
Sheets("SP").Select
Range("H6").Select
If Range("H6").Value > 0 Then
Sheets("SP").Select
Sheets("SP").Copy Before:=Workbooks("flash.xls").Sheets(1)
Columns("C:I").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Windows("Gerar Capas de Mídias V2.xlsm").Activate
End If
Sheets("CAPA").Select
Sheets("CAPA").Copy Before:=Workbooks("flash.xls").Sheets(1)
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False
Windows("Gerar Capas de Mídias V2.xlsm").Activate
Sheets("Base Clientes").Select
ActiveSheet.Range("$A$2:$AH$34383").AutoFilter Field:=1, Criteria1:="<>"
Columns("A:AD").Select
Selection.Copy
Windows("flash.xls").Activate
Sheets("Plan1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Sheets("Plan1").Name = "Relatório"
Cells.Select
Cells.EntireColumn.AutoFit
Application.CutCopyMode = False
With Selection.Font
.Name = "Calibri"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
Cells.EntireColumn.AutoFit
ActiveWindow.ScrollColumn = 2
ActiveWindow.ScrollColumn = 5
ActiveWindow.SmallScroll ToRight:=1
Range("R1").Select
ActiveCell.FormulaR1C1 = "Total="
Range("S1").Select
ActiveCell.FormulaR1C1 = "=SUM(R[2]C:R[1048575]C)"
Columns("I:S").Select
Selection.Style = "Comma"
Range("S1").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Rows("1:2").Select
Range("F1").Activate
Selection.Font.Bold = True
Range("H5").Select
Selection.End(xlToLeft).Select
Selection.End(xlUp).Select
Range("A2:S2").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.149998474074526
.PatternTintAndShade = 0
End With
ActiveWindow.ScrollColumn = 5
Range("R1:S1").Select
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Range("E3").Select
'Salvar arquivo com o nome da celula
ChDir "C:Usersallison.silvaDesktopMovimentações Diarias20147 - JUL7.07_18.07Midia Junho 2014"
ChDir "C:Usersallison.silvaDesktopMovimentações Diarias20147 - JUL7.07_18.07Midia Junho 2014"
ActiveWorkbook.SaveAs Filename:=[E3].Value & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, Local:=("C:Usersallison.silvaDesktopMovimentações Diarias20147 - JUL7.07_18.07Midia Junho 2014")
ActiveWindow.Close
Windows("Gerar Capas de Mídias V2.xlsm").Activate
Sheets("Redes").Select
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True 'Reexibir a macro na tela do excel
Application.DisplayAlerts = True 'Desativar a opção para dar sim automaticamente nos alertas
Dim MSG As String
MSG = MsgBox("Atualização de Mídia Completa") = vbOK
End Sub
Segue tambem exemplo tambem do script da barra de progresso na barra de status:
Sub BarraDeProgreso()
Dim R As Integer
Dim MT As Double
For R = 1 To 180
MT = Timer
Do
Loop While Timer - MT < 0.05
Application.StatusBar = "Progress: " & R & " de 180: " & _
Format(R / 180, "Percent") & " — " & "realizados"
DoEvents
Next R
Application.StatusBar = False
End Sub