MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    Barra de Progresso na StatusBar do Excel

    Compartilhe
    avatar
    asimoes
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 61
    Registrado : 30/04/2013

    Barra de Progresso na StatusBar do Excel

    Mensagem  asimoes em Ter 04 Nov 2014, 12:01

    Ola a todos!

    Pessoal é o seguinte, tenho um código que segue abaixo que faz uma serie de formatação à um arquivo .txt que segue em anexo. O código funciona perfeitamente, porem ñ consigo colocar uma Barra de Progresso na StatusBar! o código contem muitos loops, já fiz de tudo! e ñ sei como encaixar uma barra de progresso nele.

    Recorri a vocês porque com certeza a lógica de como colocar Barra de Progresso na StatusBar! do excel com certeza se aplica no Access.

    Peço ajuda nisso, por favor!


    - Em anexo está o .txt que a macro vai pedir
    - O código pode ser executado em qualquer aquivo do excel que contenha apenas a Plan1, Plan2 e Plan3


    Segue código:

    Código:
    Sub Gera_NivelNivel_e_Analise()

    'Desenvolvimento André E. Simões
    '-------------------------------DEFINIÇÃO DA FUNÇÃO------------------------------------------'
    ' Gera Nivel à Nivel na Planilha CONSULTA ANÁLISE com base no aquivo gerado pelo EMS (ES0506)'
    ' e colocar os níves 03 na Planilha ANÁLISE.                                                 '
    '--------------------------------------------------------------------------------------------'

    Volta:
    Semana = InputBox(Prompt:="FAVOR INFORMAR A SEMANA...", Title:="SEMANA", Default:="")

    If Semana = "" Then
       Exit Sub
    End If

    Confirma = MsgBox(Prompt:="Você confirma a nova Análise como:" + vbCrLf + "" + vbCrLf + " ANÁLISE SEM." & Semana, Title:="Confirma Analise", Buttons:=vbOKCancel + vbQuestion)

    If Confirma = vbCancel Then
       GoTo Volta
    End If

    Dim datainicio As Date
    Dim datafim As Date
    Dim resultadotempo As Date
    Dim Arquivo As String

    Arquivo = Application.GetOpenFilename("Arquivos Texto(*.txt; *.tmp), *.txt", , "Selecione o arquivo de texto gerado pela tela ES0506")

    If Arquivo <> "Falso" Then
          
       Gerador = MsgBox(Prompt:="Gerando Análise: " & "SEM." & Semana + vbCrLf + "" + vbCrLf + "Para cancelar aperte CTRL + BREAK e aperte o Botão Fim", Title:="GERADOR DE ANÁLISE", Buttons:=vbOKCancel + vbInformation)
      
       If Gerador = vbCancel Then
          Workbooks("GERADOR DE ANALISE.xlsm").Close
          Exit Sub
       End If
      
      
       Application.DisplayAlerts = False 'desabilite o alerta
       Application.ScreenUpdating = False 'DEIXA A TELA ESTATICA
          

       Analise = "ANÁLISE SEM." & Semana
      
       Sheets("Plan1").Name = Analise
       Sheets("Plan2").Name = "PLAN 02-PLAN 03"
       Sheets("Plan3").Name = "PLAN 04-PLAN 06"
       Sheets.add After:=Sheets(Sheets.Count)
       ActiveSheet.Name = "PLAN 09"
       Sheets.add After:=Sheets(Sheets.Count)
       ActiveSheet.Name = "CONSULTA ANÁLISE"
      
       Sheets("CONSULTA ANÁLISE").Select
      
       ' ---Formatação---
      
       Open Arquivo For Input As #1
       With ActiveSheet.QueryTables.add(Connection:="TEXT;" & Arquivo, Destination:=Range("a1"))
       Close
               .FieldNames = True
               .RowNumbers = False
               .FillAdjacentFormulas = False
               .PreserveFormatting = True
               .RefreshOnFileOpen = False
               .RefreshStyle = xlInsertDeleteCells
               .SavePassword = False
               .SaveData = True
               .AdjustColumnWidth = True
               .RefreshPeriod = 0
               .TextFilePromptOnRefresh = False
               .TextFilePlatform = 1252
               .TextFileStartRow = 1
               .TextFileParseType = xlFixedWidth
               .TextFileTextQualifier = xlTextQualifierDoubleQuote
               .TextFileConsecutiveDelimiter = False
               .TextFileTabDelimiter = True
               .TextFileSemicolonDelimiter = False
               .TextFileCommaDelimiter = False
               .TextFileSpaceDelimiter = False
               .TextFileColumnDataTypes = Array(2, 2, 1, 1, 1, 1, 1, 1, 1, 2, 1, 1)
               .TextFileFixedColumnWidths = Array(17, 17, 60, 19, 18, 19, 3, 3, 1, 18, 13)
               .TextFileTrailingMinusNumbers = True
               .Refresh BackgroundQuery:=False
           End With
           Rows("1:4").Select
           Range("A4").Activate
           Selection.Delete Shift:=xlUp
           Rows("2:2").Select
           Selection.Delete Shift:=xlUp
           Columns("A:A").Select
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
           Selection.Insert Shift:=xlToRight
          
           Range("A1").Select
           ActiveCell.FormulaR1C1 = "Enc"
           Range("B1").Select
           ActiveCell.FormulaR1C1 = "Cod nivel 2"
           Range("C1").Select
           ActiveCell.FormulaR1C1 = "Descrição Comp. nivel 2"
           Range("D1").Select
           ActiveCell.FormulaR1C1 = "Cod nivel 3"
           Range("E1").Select
           ActiveCell.FormulaR1C1 = "Descrição Comp. nivel 3"
           Range("F1").Select
           ActiveCell.FormulaR1C1 = "Cod nivel 4"
           Range("G1").Select
           ActiveCell.FormulaR1C1 = "Descrição Comp. nivel 4"
           Range("H1").Select
           ActiveCell.FormulaR1C1 = "Cod nivel 5"
           Range("I1").Select
           ActiveCell.FormulaR1C1 = "Descrição Comp. nivel 5"
           Range("J1").Select
           ActiveCell.FormulaR1C1 = "Cod nivel 6"
           Range("K1").Select
           ActiveCell.FormulaR1C1 = "Descrição Comp. nivel 6"
           Range("L1").Select
           ActiveCell.FormulaR1C1 = "Cod nivel 7"
           Range("M1").Select
           ActiveCell.FormulaR1C1 = "Descrição Comp. nivel 7"
           Range("N1").Select
           ActiveCell.FormulaR1C1 = "Cod nivel 8"
           Range("O1").Select
           ActiveCell.FormulaR1C1 = "Descrição Comp. nivel 8"
          
       ' --- Encomenda ---
       ' --- Nivel 1 ---
      
       Range("P2").Select
      
       While ActiveCell <> ""
       Do
          If ActiveCell = "1" Then
             Selection.Offset(0, -15) = Selection.Offset(0, 1)
             Selection.Offset(1, 0).Select
          Else
             Selection.Offset(0, -15) = Selection.Offset(-1, -15)
             Selection.Offset(1, 0).Select
          End If
       Loop Until ActiveCell = ""
       Wend
        
       ' ---Descrição---
       ' --- Nivel 2 ---
      
       Range("P3").Select
      
       While ActiveCell <> ""
       Do
          If ActiveCell = "-2" Then
             Selection.Offset(0, -14) = Selection.Offset(0, 1)
             Selection.Offset(0, -13) = Selection.Offset(0, 2)
             Selection.Offset(1, 0).Select
          Else
             Selection.Offset(0, -13) = Selection.Offset(-1, -13)
             Selection.Offset(0, -14) = Selection.Offset(-1, -14)
             Selection.Offset(1, 0).Select
          End If
       Loop Until ActiveCell = ""
       Wend
      
       ' --- Nivel 3 ---
      
       Range("P3").Select
      
       While ActiveCell <> ""
       Do
          If ActiveCell = "-2" Then
             Selection.Offset(1, 0).Select
          Else
              If ActiveCell = "--3" Then
                 Selection.Offset(0, -12) = Selection.Offset(0, 1)
                 Selection.Offset(0, -11) = Selection.Offset(0, 2)
                 Selection.Offset(1, 0).Select
              Else
                 Selection.Offset(0, -11) = Selection.Offset(-1, -11)
                 Selection.Offset(0, -12) = Selection.Offset(-1, -12)
                 Selection.Offset(1, 0).Select
              End If
          End If
       Loop Until ActiveCell = ""
       Wend
      
       ' --- Nivel 4 ---
      
       Range("P3").Select
      
       While ActiveCell <> ""
       Do
          If ActiveCell = "-2" Then
             Selection.Offset(1, 0).Select
          Else
              If ActiveCell = "--3" Then
                 Selection.Offset(1, 0).Select
              Else
                  If ActiveCell = "---4" Then
                     Selection.Offset(0, -10) = Selection.Offset(0, 1)
                     Selection.Offset(0, -9) = Selection.Offset(0, 2)
                     Selection.Offset(1, 0).Select
                  Else
                     Selection.Offset(0, -9) = Selection.Offset(-1, -9)
                     Selection.Offset(0, -10) = Selection.Offset(-1, -10)
                     Selection.Offset(1, 0).Select
                  End If
              End If
          End If
       Loop Until ActiveCell = ""
       Wend
      
       ' --- Nivel 5 ---
      
       Range("P3").Select
      
       While ActiveCell <> ""
       Do
          If ActiveCell = "-2" Then
             Selection.Offset(1, 0).Select
          Else
              If ActiveCell = "--3" Then
                 Selection.Offset(1, 0).Select
              Else
                  If ActiveCell = "---4" Then
                     Selection.Offset(1, 0).Select
                  Else
                     If ActiveCell = "----5" Then
                        Selection.Offset(0, -8) = Selection.Offset(0, 1)
                        Selection.Offset(0, -7) = Selection.Offset(0, 2)
                        Selection.Offset(1, 0).Select
                     Else
                        Selection.Offset(0, -7) = Selection.Offset(-1, -7)
                        Selection.Offset(0, -8) = Selection.Offset(-1, -8)
                        Selection.Offset(1, 0).Select
                     End If
                  End If
              End If
          End If
       Loop Until ActiveCell = ""
       Wend
      
       ' --- Nivel 6 ---
      
       Range("P3").Select
      
       While ActiveCell <> ""
       Do
          If ActiveCell = "-2" Then
             Selection.Offset(1, 0).Select
          Else
              If ActiveCell = "--3" Then
                 Selection.Offset(1, 0).Select
              Else
                  If ActiveCell = "---4" Then
                     Selection.Offset(1, 0).Select
                  Else
                      If ActiveCell = "----5" Then
                         Selection.Offset(1, 0).Select
                      Else
                         If ActiveCell = "-----6" Then
                            Selection.Offset(0, -6) = Selection.Offset(0, 1)
                            Selection.Offset(0, -5) = Selection.Offset(0, 2)
                            Selection.Offset(1, 0).Select
                         Else
                            Selection.Offset(0, -5) = Selection.Offset(-1, -5)
                            Selection.Offset(0, -6) = Selection.Offset(-1, -6)
                            Selection.Offset(1, 0).Select
                         End If
                     End If
                  End If
              End If
          End If
       Loop Until ActiveCell = ""
       Wend
      
       ' --- Nivel 7 ---
      
       Range("P3").Select
      
       While ActiveCell <> ""
       Do
          If ActiveCell = "-2" Then
             Selection.Offset(1, 0).Select
          Else
              If ActiveCell = "--3" Then
                 Selection.Offset(1, 0).Select
              Else
                  If ActiveCell = "---4" Then
                     Selection.Offset(1, 0).Select
                  Else
                      If ActiveCell = "----5" Then
                         Selection.Offset(1, 0).Select
                      Else
                         If ActiveCell = "-----6" Then
                            Selection.Offset(1, 0).Select
                         Else
                            If ActiveCell = "------7" Then
                               Selection.Offset(0, -4) = Selection.Offset(0, 1)
                               Selection.Offset(0, -3) = Selection.Offset(0, 2)
                               Selection.Offset(1, 0).Select
                            Else
                               Selection.Offset(0, -3) = Selection.Offset(-1, -3)
                               Selection.Offset(0, -4) = Selection.Offset(-1, -4)
                               Selection.Offset(1, 0).Select
                            End If
                         End If
                     End If
                  End If
              End If
          End If
       Loop Until ActiveCell = ""
       Wend
      
       ' --- Nivel 8 ---
      
       Range("P3").Select
      
       While ActiveCell <> ""
       Do
          If ActiveCell = "-2" Then
             Selection.Offset(1, 0).Select
          Else
              If ActiveCell = "--3" Then
                 Selection.Offset(1, 0).Select
              Else
                  If ActiveCell = "---4" Then
                     Selection.Offset(1, 0).Select
                  Else
                      If ActiveCell = "----5" Then
                         Selection.Offset(1, 0).Select
                      Else
                         If ActiveCell = "-----6" Then
                            Selection.Offset(1, 0).Select
                         Else
                            If ActiveCell = "------7" Then
                               Selection.Offset(1, 0).Select
                            Else
                               If ActiveCell = "-------8" Then
                                  Selection.Offset(0, -2) = Selection.Offset(0, 1)
                                  Selection.Offset(0, -1) = Selection.Offset(0, 2)
                                  Selection.Offset(1, 0).Select
                               Else
                                  Selection.Offset(0, -1) = Selection.Offset(-1, -1)
                                  Selection.Offset(0, -2) = Selection.Offset(-1, -2)
                                  Selection.Offset(1, 0).Select
                               End If
                            End If
                         End If
                     End If
                  End If
              End If
          End If
       Loop Until ActiveCell = ""
       Wend
      
       '-----FORMATAÇÃO APOS CONCLUIR-----
      
       '------Exclui colunas-------
       Columns("S:T").Select 'Quantidade Usada e Saldo Estoque
       Selection.Delete Shift:=xlToLeft
          
       Columns("V:X").Select ' T, Desenho, comprador
       Selection.Delete Shift:=xlToLeft
      
       '----Insere novas colunas----
       Columns("B:B").Select
       Selection.Insert Shift:=xlToRight
       Selection.Insert Shift:=xlToRight
       Selection.Insert Shift:=xlToRight
          
       '----Move colunas----
       Columns("T:V").Select
       Selection.Cut Destination:=Columns("B:D")
          
       '------Exclui colunas movidas-------
       Selection.Delete Shift:=xlToLeft
            
       '----Altera desc colula D1----
       Range("D1").Select
       ActiveCell.FormulaR1C1 = "Qtde"
      
       '----Altera desc colula W1----
       Range("W1").Select
       ActiveCell.FormulaR1C1 = "Comp. Direto De"
       Range("X1").Select
       ActiveCell.FormulaR1C1 = "Descrição Comp. Direto De"
          
       '----ACERTA PARA PROCV COMP.----
      
       Range("B2").Select
      
       While ActiveCell <> ""
       Do
      
       If Selection.Offset(0, 21) = "" Then
      
          If Selection.Offset(0, 15) <> "" And Selection.Offset(0, 15) <> ActiveCell Then
             Selection.Offset(0, 21) = Selection.Offset(0, 15)
             Selection.Offset(0, 22) = Selection.Offset(0, 16)
          Else
             If Selection.Offset(0, 13) <> "" And Selection.Offset(0, 13) <> ActiveCell Then
                Selection.Offset(0, 21) = Selection.Offset(0, 13)
                Selection.Offset(0, 22) = Selection.Offset(0, 14)
             Else
                If Selection.Offset(0, 11) <> "" And Selection.Offset(0, 11) <> ActiveCell Then
                   Selection.Offset(0, 21) = Selection.Offset(0, 11)
                   Selection.Offset(0, 22) = Selection.Offset(0, 12)
                Else
                   If Selection.Offset(0, 9) <> "" And Selection.Offset(0, 9) <> ActiveCell Then
                      Selection.Offset(0, 21) = Selection.Offset(0, 9)
                      Selection.Offset(0, 22) = Selection.Offset(0, 10)
                   Else
                      If Selection.Offset(0, 7) <> "" And Selection.Offset(0, 7) <> ActiveCell Then
                         Selection.Offset(0, 21) = Selection.Offset(0, 7)
                         Selection.Offset(0, 22) = Selection.Offset(0,
                      Else
                         If Selection.Offset(0, 5) <> "" And Selection.Offset(0, 5) <> ActiveCell Then
                            Selection.Offset(0, 21) = Selection.Offset(0, 5)
                            Selection.Offset(0, 22) = Selection.Offset(0, 6)
                         Else
                            If Selection.Offset(0, 3) <> "" And Selection.Offset(0, 3) <> ActiveCell Then
                               Selection.Offset(0, 21) = Selection.Offset(0, 3)
                               Selection.Offset(0, 22) = Selection.Offset(0, 4)
                            Else
                               Selection.Offset(1, 0).Select
          End If
               End If
                    End If
                          End If
                              End If
                                  End If
                                      End If
              
       Else
          Selection.Offset(1, 0).Select
       End If
      
       Loop Until ActiveCell = ""
       Wend
      
       '------Pinta Fundo cabeçalho-------
       Range("A1:X1").Select
       With Selection.Interior
           .PatternColorIndex = xlAutomatic
           .ThemeColor = xlThemeColorLight1
           .TintAndShade = 0
           .PatternTintAndShade = 0
       End With
          
       '------Pinta Fonte cabeçalho------
           With Selection.Font
               .ThemeColor = xlThemeColorDark1
               .TintAndShade = 0
           End With
           Selection.Font.Bold = True
      
       '----Coloca filtro----
       Selection.AutoFilter
       '----Acerta espaçamento colulas----
       ActiveWindow.Zoom = 85
       Cells.Select
       Cells.EntireColumn.AutoFit
       Range("A1").Select
     
    Else
    MsgBox "Nenhum arquivo foi selecionado."
    Workbooks("GERADOR DE ANALISE.xlsm").Close
    Exit Sub
    End If

    '-------------------------------DEFINIÇÃO DA FUNÇÃO-----------------------------------'
    ' Exportar nivel 03 da planilha CONSULTA ANÁLISE para a PLANILHA ANÁLISE.             '
    '-------------------------------------------------------------------------------------'
    Dim add As Integer
    Dim add1 As Integer

    Sheets(Analise).Select

    '-------FORMATA ABA ANALISE--------
        Range("A1") = Analise
      
        Range("A1:H2").Select
        With Selection.Font
            .Name = "Calibri"
            .Size = 20
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .ThemeFont = xlThemeFontMinor
        End With
        Selection.Font.Bold = True

        Range("A1:H2").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
        With Selection.Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
          
        Range("A3").Select
        ActiveCell.FormulaR1C1 = "Componente"
        Range("B3").Select
        ActiveCell.FormulaR1C1 = "Descrição"
        Range("C3").Select
        ActiveCell.FormulaR1C1 = "F"
        Range("D3").Select
        ActiveCell.FormulaR1C1 = "Plan 02/Plan 03"
        Range("E3").Select
        ActiveCell.FormulaR1C1 = "Plan 04/Plan 06"
        Range("F3").Select
        ActiveCell.FormulaR1C1 = "Plan 09"
        Range("G3").Select
        ActiveCell.FormulaR1C1 = "U.P.S."
        Range("H3").Select
        ActiveCell.FormulaR1C1 = "Divergências"
        Range("A3:H3").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        Selection.Font.Bold = True
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ThemeColor = 1
            .TintAndShade = 0
            .Weight = xlThin
        End With
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        Selection.Borders(xlInsideVertical).LineStyle = xlNone
        Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
        Range("A3:R3").Select
        Selection.AutoFilter
        Range("A4").Select

    '-------FINALIZA FORMATAÇÃO ABA ANALISE--------

    Sheets("CONSULTA ANÁLISE").Select
        
    Do While Not ActiveSheet.Cells(2 + add, 2) = ""
       If ActiveSheet.Cells(2 + add, 19) = "--3" Then
          Range("B" & 2 + add, "C" & 2 + add).Copy
          Sheets(Analise).Select
          ActiveSheet.Cells(4 + add1, 1).Select
          ActiveSheet.Paste
          Sheets("CONSULTA ANÁLISE").Select
          Range("U" & 2 + add).Copy
          Sheets(Analise).Select
          ActiveSheet.Cells(4 + add1, 3).Select
          ActiveSheet.Paste
          add1 = add1 + 1
          add = add + 1
       Else
           add = add + 1
       End If
    Sheets("CONSULTA ANÁLISE").Select
    Loop
       Sheets(Analise).Select
       Columns("A:G").Select
       ActiveSheet.Range("$A$4:$G$90000").RemoveDuplicates Columns:=1, Header:=xlYes
        
       Sheets(Analise).Select
       Columns("A:H").Select
       Columns("A:H").EntireColumn.AutoFit
       Range("A4").Select
       ActiveWindow.Zoom = 85
     
    '---------Formata Planilha PLAN 02-PLAN 03---------------

        Sheets("PLAN 02-PLAN 03").Select
        Range("A1") = Analise
        Range("A1:R3").Select
        Selection.Font.Bold = True
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        With Selection.Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
        Range("A1:R2").Select
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlBottom
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = False
        End With
        Selection.Merge
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .WrapText = False
            .Orientation = 0
            .AddIndent = False
            .IndentLevel = 0
            .ShrinkToFit = False
            .ReadingOrder = xlContext
            .MergeCells = True
        End With
        With Selection.Font
            .Name = "Calibri"
            .Size = 20
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
            .ThemeFont = xlThemeFontMinor
        End With
        Range("A1:R3").Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        Selection.Borders(xlEdgeLeft).LineStyle = xlNone
        Selection.Borders(xlEdgeTop).LineStyle = xlNone
        Selection.Borders(xlEdgeBottom).LineStyle = xlNone
        Selection.Borders(xlEdgeRight).LineStyle = xlNone
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ThemeColor = 1
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ThemeColor = 1
            .TintAndShade = 0
            .Weight = xlThin
        End With
        Range("A3").Select
        ActiveCell.FormulaR1C1 = "Enc"
        Range("B3").Select
        ActiveCell.FormulaR1C1 = "Plan Sistema"
        Range("C3").Select
        ActiveCell.FormulaR1C1 = "Situação"
        Range("D3").Select
        ActiveCell.FormulaR1C1 = "Plan"
        Range("E3").Select
        ActiveCell.FormulaR1C1 = "Setor"
        Range("F3").Select
        ActiveCell.FormulaR1C1 = "Sigla"
        Range("G3").Select
        ActiveCell.FormulaR1C1 = "Observação"
        Range("H3").Select
        ActiveCell.FormulaR1C1 = "O/S"
        Range("I3").Select
        ActiveCell.FormulaR1C1 = "Componente"
        Range("J3").Select
        ActiveCell.FormulaR1C1 = "Descrição Componente"
        Range("K3").Select
        ActiveCell.FormulaR1C1 = "Qtde"
        Range("L3").Select
        ActiveCell.FormulaR1C1 = "Stq"
        Range("M3").Select
        ActiveCell.FormulaR1C1 = "Saldo Dis 07"
        Range("N3").Select
        ActiveCell.FormulaR1C1 = "Saldo Dis 07B"
        Range("O3").Select
        ActiveCell.FormulaR1C1 = "100"
        Range("P3").Select
        ActiveCell.FormulaR1C1 = "Nível"
        Range("Q3").Select
        ActiveCell.FormulaR1C1 = "Und"
        Range("R3").Select
        ActiveCell.FormulaR1C1 = "F"
        Range("A3:R3").Select
        Selection.AutoFilter
        ActiveWindow.Zoom = 85

    '----------Finaliza Formatação Planilha PLAN 02-PLAN 03--------------

    '----------Coloca informação da planilha CONSULTA ANALISE na Planilha PLAN 02-PLAN 03--------------

       Sheets("CONSULTA ANÁLISE").Select
       Range("A2:A1048510").Select
       Selection.Copy
       Sheets("PLAN 02-PLAN 03").Select
       Range("A4").Select
       ActiveSheet.Paste
        
       Sheets("CONSULTA ANÁLISE").Select
       Range("V2:V1048510").Select
       Selection.Copy
       Sheets("PLAN 02-PLAN 03").Select
       Range("B4").Select
       ActiveSheet.Paste
        
       Sheets("CONSULTA ANÁLISE").Select
       Range("B2:D1048510").Select
       Selection.Copy
       Sheets("PLAN 02-PLAN 03").Select
       Range("I4").Select
       ActiveSheet.Paste
      
       Sheets("CONSULTA ANÁLISE").Select
       Range("S2:U1048510").Select
       Selection.Copy
       Sheets("PLAN 02-PLAN 03").Select
       Range("P4").Select
       ActiveSheet.Paste
        
    '----------Finaliza Coloca informação da planilha CONSULTA ANALISE na Planilha PLAN 02-PLAN 03--------------

    '----------Retira Itens desnecessarios da planilha PLAN 02-PLAN 03--------------
      
        Range("A4").Select
        ActiveSheet.Range("$A$3:$R$1048576").AutoFilter Field:=16, Criteria1:="=1", Operator:=xlOr, Criteria2:="=-2"
        Selection.End(xlDown).Select
        Selection.End(xlUp).Select
        Selection.Offset(1, 0).Select
        Rows(ActiveCell.Row).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Delete Shift:=xlUp
        ActiveSheet.Range("$A$3:$R$1048576").AutoFilter Field:=16
        
        Range("A4").Select
        ActiveSheet.Range("$A$3:$R$1048576").AutoFilter Field:=9, Criteria1:="=9*", Operator:=xlAnd
        Selection.End(xlDown).Select
        Selection.End(xlUp).Select
        Selection.Offset(1, 0).Select
        Rows(ActiveCell.Row).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Delete Shift:=xlUp
        ActiveSheet.Range("$A$3:$R$1048576").AutoFilter Field:=9

        Range("A4").Select
        ActiveSheet.Range("$A$3:$R$1048576").AutoFilter Field:=9, Criteria1:="=F*", Operator:=xlAnd
        Selection.End(xlDown).Select
        Selection.End(xlUp).Select
        Selection.Offset(1, 0).Select
        Rows(ActiveCell.Row).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Delete Shift:=xlUp
        ActiveSheet.Range("$A$3:$R$1048576").AutoFilter Field:=9
        
        Range("A4").Select
        ActiveSheet.Range("$A$3:$R$1048576").AutoFilter Field:=9, Criteria1:="=C*", Operator:=xlAnd
        Selection.End(xlDown).Select
        Selection.End(xlUp).Select
        Selection.Offset(1, 0).Select
        Rows(ActiveCell.Row).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.Delete Shift:=xlUp
        ActiveSheet.Range("$A$3:$R$1048576").AutoFilter Field:=9
        ActiveWindow.Zoom = 85
        Cells.Select
        Cells.EntireColumn.AutoFit

    '----------Finaliza Retira Itens desnecessarios da planilha PLAN 02-PLAN 03--------------

    '----------Copia informações da planilha PLAN 02-PLAN 03 e cola na planilha PLAN 04-PLAN 06 E PLAN 09--------------

        Cells.Select
        Selection.Copy
        Sheets("PLAN 04-PLAN 06").Select
        Range("A1").Select
        ActiveSheet.Paste
        ActiveWindow.Zoom = 85
        Range("A3:R3").Select
        Selection.AutoFilter
        Cells.Select
        Cells.EntireColumn.AutoFit
        Range("A4").Select
        
        Sheets("PLAN 02-PLAN 03").Select
        Cells.Select
        Selection.Copy
        Sheets("PLAN 09").Select
        Range("A1").Select
        ActiveSheet.Paste
        ActiveWindow.Zoom = 85
        Range("A3:R3").Select
        Selection.AutoFilter
        Cells.Select
        Cells.EntireColumn.AutoFit
        Range("A4").Select
        
    '----------Finalisa Copia informações da planilha PLAN 02-PLAN 03 e cola na planilha PLAN 04-PLAN 06 E PLAN 09--------------

    Sheets("PLAN 02-PLAN 03").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("PLAN 04-PLAN 06").Select
    ActiveWindow.SelectedSheets.Visible = False
    Sheets("PLAN 09").Select
    ActiveWindow.SelectedSheets.Visible = False

    Workbooks("GERADOR DE ANALISE.xlsm").Close

    Application.ScreenUpdating = True 'RETIRA A TELA ESTATICA
    Application.DisplayAlerts = True 'habilite novamente o alerta

    End Sub



    Segue agora o código da Barra de Progresso na StatusBar que ñ consigo encaixar

    Código:
    Sub BarraDeProgresso()
    Dim i               As Long
    Dim iUltimaLinha    As Long
    Dim sStatusProcesso As String
     
        iUltimaLinha = ActiveSheet.Range("A1").End(xlDown).Row
     
        sStatusProcesso = "Aguarde... O sistema está processando as informações. "
     
        Application.StatusBar = sStatusProcesso
     
        For i = 2 To iUltimaLinha
            Application.StatusBar = sStatusProcesso & Format(i / iUltimaLinha, "0.0%") & " Concluído"
            ' O código vai aqui...
            
        Next
     
        Application.StatusBar = False
     
        MsgBox "Processo concluído.", vbInformation, "Excel do Seu Jeito"
     
    End Sub
    Anexos
    es0506rp.txt
    Você não tem permissão para fazer download dos arquivos anexados.
    (902 Kb) Baixado 11 vez(es)


    .................................................................................
    Não tenho medo de compartilhar conhecimento.
    Essa é a unica coisa que as pessoas não poderão roubar de mim, pois ninguém nunca sabe igual, mesmo que saiba a mesma coisa.
    avatar
    Alexandre Neves
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6548
    Registrado : 05/11/2009

    Re: Barra de Progresso na StatusBar do Excel

    Mensagem  Alexandre Neves em Ter 04 Nov 2014, 14:17

    Boa tarde,
    Movi o tema para esta sala. O fórum está vocacionado para o Access


    .................................................................................
    Access 2010. Mande bd que dê para testar (indique a versão). Não peça para fazer o que já tem feito. Dê todos os detalhes.
    Não coloquem entraves como senhas, esconder controlos, etc. Disponibilizem o mais limpo possível
    Só respondo a mensagens privadas, se forem de assunto privado; às outras não respondo.
    Quem trabalha e mata a fome não come o pão de ninguém; mas quem não trabalha e come, come sempre o pão de alguém. António Aleixo

      Data/hora atual: Qui 14 Dez 2017, 02:06