Ir ao conteúdo
  • Comunicados

    • Gabriel Torres

      Seja um moderador do Clube do Hardware!   12-02-2016

      Prezados membros do Clube do Hardware, Está aberto o processo de seleção de novos moderadores para diversos setores ou áreas do Clube do Hardware. Os requisitos são:   Pelo menos 500 posts e um ano de cadastro; Boa frequência de participação; Ser respeitoso, cordial e educado com os demais membros; Ter bom nível de português; Ter razoável conhecimento da área em que pretende atuar; Saber trabalhar em equipe (com os moderadores, coordenadores e administradores).   Os interessados deverão enviar uma mensagem privada para o usuário @Equipe Clube do Hardware com o título "Candidato a moderador". A mensagem deverá conter respostas às perguntas abaixo:   Qual o seu nome completo? Qual sua data de nascimento? Qual sua formação/profissão? Já atuou como moderador em algo outro fórum, se sim, qual? De forma sucinta, explique o porquê de querer ser moderador do fórum e conte-nos um pouco sobre você.   OBS: Não se trata de função remunerada. Todos que fazem parte do staff são voluntários.
    • DiF

      Poste seus códigos corretamente!   21-05-2016

      Prezados membros do Fórum do Clube do Hardware, O Fórum oferece um recurso chamado CODE, onde o ícone no painel do editor é  <>     O uso deste recurso é  imprescindível para uma melhor leitura, manter a organização, diferenciar de texto comum e principalmente evitar que os compiladores e IDEs acusem erro ao colar um código copiado daqui. Portanto convido-lhes para ler as instruções de como usar este recurso CODE neste tópico:  
FSoares.FCS

Barra de Progresso VBA

Recommended Posts

FSoares.FCS    0

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

image.thumb.png.90f938070a225d11ef193f14aa824114.png

Compartilhar este post


Link para o post
Compartilhar em outros sites

Crie uma conta ou entre para comentar

Você precisar ser um membro para fazer um comentário






Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas publicações sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

×