none
Performance VBA excel 2010 x 2007: Excel 2010 está pior!!! RRS feed

  • Pergunta

  • Olá!!

    Estou fazendo um programa para transformar um banco de dados em um formulário com a formatação adequada para ser impresso, trata-se de um formulário com várias questões onde cada questão tem seus respectivos itens (checkboxes).

    O programa exige muito do computador, uma vez que o banco de dados possui mais de 3000 linhas. Quando rodo no excel 2010 o processamento fica muito lento, levando horas para rodar, porém quando rodo no excel 2007 leva cerca de 15 minutos para rodar.

    Alguém sabe explicar porque em uma versão mais nova do excel a performance do programa cai?? há alguma forma de corrigir este problema?

    Obrigado!!
    sexta-feira, 27 de dezembro de 2013 02:53

Respostas

  • Adicionando mais comoentários em cima do que o Felipe falou:

    Não atualize a sua barra de progresso a cada iteração do seu laço. Por que não fazer uma atualização gráfica apenas de 10 em 10 itens? Troque:

    Application.StatusBar = lgp / (Range("maior") + 1) * 100 & " % do Relatório Gerado" 'cria barra para acompanhamento da macro

    por:

    If lgp Mod 10 = 0 Then
      Application.StatusBar = lgp / (Range("maior") + 1) * 100 & " % do Relatório Gerado" 'cria barra para acompanhamento da macro
    End If

    ---

    Experimente, além de desabilitar a propriedade ScreenUpdating, mudar a forma de cálculo do Excel. Para ganhar mais velocidade:

    Application.Calculation = xlCalculationManual

    Para voltar ao padrão do Excel:

    Application.Calculation = xlCalculationAutomatic

    ---

    Na minha opinião, o que torna a rotina demorada é a criação de objetos CheckBox. No entanto, você deve criar várias caixas de seleção, não é? Nesse caso, não tem jeito de sugerir algo diferente.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sábado, 28 de dezembro de 2013 22:58
    Moderador

Todas as Respostas

  • Olá,

    Não sei qual é o tipo de processamento que vcoê faz nos seus dados, mas 3000 linhas não é tanto assim para o Excel.

    Não sei falar agora por que o código no Excel 2010 está mais lento, mas será que o código pode ser melhorado para termos um desempenho melhor? Afinal, até mesmo os 15 minutos é muito tempo.

    Poderia postar o código que está usando?


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sexta-feira, 27 de dezembro de 2013 13:54
    Moderador
  • Olá Felipe,

    Desde que postei consegui melhorar o código e a performance, agora está:

    excel 2010: 15 minutos

    excel 2007: 20 segundos

    A performance melhorou muito mas ainda há uma diferença significativa entre as versões do excel!! porque sera?

    São 3000 linhas que o excel analisa vários pontos e gera um relatório com certa de 8000 linhas. 

    Vou postar o código, mas ele esta m pouco grande. Muito obrigado pela ajuda

    Option Explicit
    Const coluna As Byte = 15
    Dim anterior(3), resposta, item1, item2, item3, item4, lrest As Byte
    Dim caracteres, lgp As Integer
    Dim cb As Shape
    Dim linha As Long
    Dim celula, area_imp As String
    Dim ultimalinha, pulou_pagina, primeiro As Boolean
    Dim check As OLEObject
    
    
    Private Sub CB_formulario_excel_Click()  
        
      Application.ScreenUpdating = False 'Paralisa atualizacao de pagina
      Application.DisplayStatusBar = True
      Application.EnableEvents = False
      ActiveSheet.DisplayPageBreaks = False
        
    'INTRODUÇÃO
        If tb_faag.Value = False And tb_faag_fc.Value = False Then ' Avalia se algum tipo de formulário foi selecionado
            MsgBox ("Selecione o tipo de formulário: FAAG ou FAAG-FC")
            Exit Sub
        End If
    
        UF_inicial.Hide
    
        resposta = MsgBox("ESTE PROCESSO PODE DEMORAR ALGUNS MINUTOS", vbOKCancel + vbExclamation, "ANEEL/SFG") 'Gera aviso de espera
        
        If resposta = 2 Then
            Exit Sub
        End If
        
        Worksheets("FORMULARIO").Activate
        
        For Each cb In Worksheets("FORMULARIO").Shapes 'Apaga todos os checkboxes do relatorio anterior
            cb.Delete
        Next
        Columns("A:J").Select  'apaga relatorio anterior
        Selection.Delete Shift:=xlToLeft
        
        'Gera definicao padrao
        Cells.Select
        Selection.RowHeight = coluna
        Selection.ColumnWidth = 8.43
        Columns("A:A").ColumnWidth = 0.1
        Columns("A:A").Select
        With Selection.Font
            .Bold = True
            .Size = 8
            .Name = "Arial Narrow"
        End With
        Columns("B:B").Select
        With Selection.Font
            .Bold = False
            .Size = 8
            .Name = "Arial Narrow"
        End With
        
        If tb_faag.Value = True Then
            Range("formulario_sel") = "FAAG"
        Else
            Range("formulario_sel") = "FAAG-FC"
            Application.Goto Reference:="capa_faag_fc" 'Acrescenda tabela de dados na primeira pagina apenas para FAAG-FC
            Selection.Copy
            Sheets("FORMULARIO").Activate
            Range("A30").Select
            ActiveSheet.Paste
        End If
        
    
    'GERA FORMULÁRIO EM  BRANCO
        
    'CAPA
        Worksheets("FORMULARIO").Activate
        Range("E8").Value = Sheets("DADOS_FOR").Range("titulo1").Value 'CRIA TEXTOS DA CAPA
        Range("E15").Value = Sheets("DADOS_FOR").Range("titulo2").Value
        Range("E16").Value = Sheets("DADOS_FOR").Range("titulo3").Value
        Range("E23").Value = Sheets("DADOS_FOR").Range("titulo4").Value
        Range("E24").Value = Sheets("DADOS_FOR").Range("titulo5").Value
        Range("E25").Value = Sheets("DADOS_FOR").Range("titulo6").Value
        Range("E26").Value = Sheets("DADOS_FOR").Range("titulo7").Value
        Range("E8:E26").Select
    
        With Selection.Font 'FORMATA CAPA
            .Name = "Arial Narrow"
            .Size = 12
            .Bold = True
        End With
        Selection.HorizontalAlignment = xlCenter
       
       
    'CADASTRO DA CENTRAL
    
        Application.Goto Reference:="cadastro_" & Sheets("DADOS_FOR").Range("usina_sel").Value 'Copia o cadastro da central para o relatório
        Selection.Copy
        Sheets("FORMULARIO").Activate
        celula = "A" & (2 * linha_pag + 1)
        Range(celula).Select
        ActiveSheet.Paste
        
    'PERGUNTAS
    
    lgr = 3 * linha_pag + 1
    
    item1 = 1 'Contador item x
    item2 = 0 'Contador item x.x
    item3 = 0 'Contador item x.x.x
    item4 = 0 'Contador item x.x.x.x
    anterior(1) = 0 'Identifica o que foi a ultima impressao (item x, x.x, etc ou checkbox)
    anterior(2) = 0
    anterior(3) = 0
    ultimalinha = False 'Identifica quando e a ultima linha de uma pergunta
    
        For lgp = 1 To 200 'Range("maior") + 1 'Passa por todas as linhas do formulario de perguntas
        
            Application.StatusBar = lgp / (Range("maior") + 1) * 100 & " % do Relatório Gerado" 'cria barra para acompanhamento da macro
            
            If Sheets("PLANILHA GERAL").Cells(lgp, Range("usina_coluna")) = "x" Then 'Checa se o item é pertinente ao tipo de usina
                
                If Sheets("PLANILHA GERAL").Cells(lgp, 2) <> "" Then 'Checa se tem o item x
                    item1 = item1 + 1
                    item2 = 0
                
                    lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag 'qtd linha que resta para completar uma pagina
                    
                    If lrest = 1 Then 'Checa se nao e a ultima linha da pagina
                        lgr = lgr + 1
                        
                    End If
                    
                    Sheets("FORMULARIO").Cells(lgr, 1) = item1 & " " & Sheets("PLANILHA GERAL").Cells(lgp, 2)
                    Cells(lgr, 1).Font.Size = 12
                    
                    lgr = lgr + 1
                    anterior(3) = anterior(2)
                    anterior(2) = anterior(1)
                    anterior(1) = 1
                    
                End If
        
                If Sheets("PLANILHA GERAL").Cells(lgp, 4) <> "" Then 'Checa se tem o item x.x
                    item2 = item2 + 1
                    item3 = 0
                                    
                    lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                    pulou_pagina = False
                    
                    Sheets("FORMULARIO").Cells(lgr, 1) = item1 & "." & item2 & " " & Sheets("PLANILHA GERAL").Cells(lgp, 4)
                    
                    caracteres = Len(Sheets("FORMULARIO").Cells(lgr, 1))
                    
                    primeiro = False
                    While lrest <= (2 + Int(caracteres / 85))
                        If anterior(1) = 1 And primeiro = False Then
                            lgr = lgr - 1
                            primeiro = True
                        End If
                        
                        Rows(lgr).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                        lgr = lgr + 1
                        lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                        pulou_pagina = True
                    Wend
                    
                    If primeiro = True Then
                        lgr = lgr + 1
                    End If
                    
                    If caracteres > 85 Then 'Checa quantidade de caracteres para quebrar frase em outra linha
                        Range(Cells(lgr, 1), Cells(lgr + Int(caracteres / 85), 10)).Select
                        With Selection
                            .MergeCells = True
                            .WrapText = True
                            .HorizontalAlignment = xlLeft
                            .VerticalAlignment = xlCenter
                            .InsertIndent 1
                        End With
                        With Selection.Font
                            .Size = 12
                        End With
                    Else
                        Cells(lgr, 1).Font.Size = 12
                        Cells(lgr, 1).InsertIndent 1
                    End If
                             
                    lgr = lgr + 1 + Int(caracteres / 85)
                    anterior(3) = anterior(2)
                    anterior(2) = anterior(1)
                    anterior(1) = 2
                End If
        
                If Sheets("PLANILHA GERAL").Cells(lgp, 6) <> "" Then 'Checa se tem o item x.x.x
                    item3 = item3 + 1
                    item4 = 0
                
                    lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                    pulou_pagina = False
                    
                    Sheets("FORMULARIO").Cells(lgr, 1) = item1 & "." & item2 & "." & item3 & " " & Sheets("PLANILHA GERAL").Cells(lgp, 6)
                    
                    caracteres = Len(Sheets("FORMULARIO").Cells(lgr, 1))
                    
                    primeiro = False
                    While lrest <= (2 + Int(caracteres / 83))
                        If anterior(1) = 2 And anterior(2) = 1 And primeiro = False Then
                            lgr = lgr - 2
                            primeiro = True
                        ElseIf anterior(1) = 2 And primeiro = False Then
                            lgr = lgr - 1
                            primeiro = True
                        End If
                        
                            Rows(lgr).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            lgr = lgr + 1
                            lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                            pulou_pagina = True
                    Wend
                    
                    If primeiro = True And anterior(1) = 2 And anterior(2) = 1 Then
                        lgr = lgr + 2
                    ElseIf primeiro = True And anterior(1) = 2 Then
                        lgr = lgr + 1
                    End If
                    
                    caracteres = Len(Sheets("FORMULARIO").Cells(lgr, 1))
                    If caracteres > 83 Then 'Checa quantidade de caracteres para quebrar frase em outra linha
                        Range(Cells(lgr, 1), Cells(lgr + Int(caracteres / 83), 10)).Select
                        With Selection
                            .MergeCells = True
                            .WrapText = True
                            .HorizontalAlignment = xlLeft
                            .VerticalAlignment = xlCenter
                            .InsertIndent 2
                        End With
                        With Selection.Font
                            .Size = 12
                        End With
                    Else
                        Cells(lgr, 1).Font.Size = 12
                        Cells(lgr, 1).InsertIndent 2
                    End If
                            
                    lgr = lgr + 1 + Int(caracteres / 83)
                    anterior(3) = anterior(2)
                    anterior(2) = anterior(1)
                    anterior(1) = 3
                End If
        
                If Sheets("PLANILHA GERAL").Cells(lgp, 8) <> "" Then 'Checa se tem o item x.x.x.x
                    item4 = item4 + 1
                    
                    
                    lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                    pulou_pagina = False
                    
                    Sheets("FORMULARIO").Cells(lgr, 1) = item1 & "." & item2 & "." & item3 & "." & item4 & " " & Sheets("PLANILHA GERAL").Cells(lgp, 8)
                    
                    caracteres = Len(Sheets("FORMULARIO").Cells(lgr, 1))
                    
                    primeiro = False
                    While lrest <= (2 + Int(caracteres / 81))
                        If anterior(1) = 3 And anterior(2) = 2 And anterior(3) = 1 And primeiro = False Then
                            lgr = lgr - 3
                            primeiro = True
                        ElseIf anterior(1) = 3 And anterior(2) = 2 And primeiro = False Then
                            lgr = lgr - 2
                            primeiro = True
                        ElseIf anterior(1) = 3 And primeiro = False Then
                            lgr = lgr - 1
                            primeiro = True
                        End If
                        
                            Rows(lgr).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            lgr = lgr + 1
                            lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                            pulou_pagina = True
                    Wend
                    
                    If primeiro = True And anterior(1) = 3 And anterior(2) = 2 And anterior(3) = 1 Then
                        lgr = lgr + 3
                    ElseIf primeiro = True And anterior(1) = 3 And anterior(2) = 2 Then
                        lgr = lgr + 2
                    ElseIf primeiro = True And anterior(1) = 3 Then
                        lgr = lgr + 1
                    End If
           
                    caracteres = Len(Sheets("FORMULARIO").Cells(lgr, 1))
                    If caracteres > 81 Then 'Checa quantidade de caracteres para quebrar frase em outra linha
                        Range(Cells(lgr, 1), Cells(lgr + Int(caracteres / 81), 10)).Select
                        With Selection
                            .MergeCells = True
                            .WrapText = True
                            .HorizontalAlignment = xlLeft
                            .VerticalAlignment = xlCenter
                            .InsertIndent 3
                        End With
                        With Selection.Font
                            .Size = 12
                        End With
                    Else
                        Cells(lgr, 1).Font.Size = 12
                        Cells(lgr, 1).InsertIndent 3
                    End If
                            
                    lgr = lgr + 1 + Int(caracteres / 81)
                    
                    anterior(3) = anterior(2)
                    anterior(2) = anterior(1)
                    anterior(1) = 4
                End If
        
                If Sheets("PLANILHA GERAL").Cells(lgp, 10) <> "" Then 'Gera CheckBox
                
                    lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag 'Checa se checkbox está na ultima linha da pagina, se sim pula uma linha
                    If lrest = 1 Then
                        lgr = lgr + 1
                    End If
                    
                    caracteres = Len(Sheets("PLANILHA GERAL").Cells(lgp, 10))
                    
    '                Set check = ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, _
    '                DisplayAsIcon:=False, Left:=6, Top:=(lgr - 1) * coluna, Width:=420, Height:=2 + coluna * Int(caracteres / 100 + 0.9999))
    '                lgr = lgr + 1 + Int(caracteres / 100)
                   
    '                With check.Object
    '                    .Caption = Sheets("PLANILHA GERAL").Cells(lgp, 10)
    '                End With
                    
                    linha = (lgr - 1) * coluna
                    ActiveSheet.CheckBoxes.Add(32, linha, 380, coluna * Int(caracteres / 100 + 0.9999)).Select
                    lgr = lgr + 1 + Int(caracteres / 100)
                    
                    With Selection
                    .Caption = Sheets("PLANILHA GERAL").Cells(lgp, 10)
                    End With
                    
                    anterior(3) = anterior(2)
                    anterior(2) = anterior(1)
                    anterior(1) = 5
                
                End If
    
                If tb_faag.Value = True Then 'Analisa de é FAAG ou FAAG-FC para gerar a instrucao de preenchimento correta
    
                    If Sheets("PLANILHA GERAL").Cells(lgp, 19) <> "" Then 'Gera instrucao de preenchimento
                        ultimalinha = True
                        Sheets("FORMULARIO").Cells(lgr, 1) = "- Instrução de Preenchimento:"
                        lgr = lgr + 1
                        Sheets("FORMULARIO").Cells(lgr, 2) = Sheets("PLANILHA GERAL").Cells(lgp, 19)
                        
                        caracteres = Len(Sheets("FORMULARIO").Cells(lgr, 2))
                    
                        If caracteres > 130 Then 'Checa quantidade de caracteres para quebrar frase em outra linha
                            Range(Cells(lgr, 2), Cells(lgr + Int(caracteres / 130), 10)).Select
                            With Selection
                                .MergeCells = True
                                .WrapText = True
                                .HorizontalAlignment = xlLeft
                                .VerticalAlignment = xlTop
                            End With
                        Else
                            Cells(lgr, 1).Font.Bold = False
                        End If
                             
                        lgr = lgr - 1
                        lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag  'checa se definicao do item ficou em duas paginas
                        
                        While lrest < (1 + Int(caracteres / 130 + 0.999999))
                            Rows(lgr).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            lgr = lgr + 1
                            lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                            
                        Wend
                             
                        lgr = lgr + 2 + Int(caracteres / 130)
                        
                    End If
                
                Else
                
                    If Sheets("PLANILHA GERAL").Cells(lgp, 20) <> "" Then 'Gera instrucao de preenchimento
                        ultimalinha = True
                        Sheets("FORMULARIO").Cells(lgr, 1) = "- Instrução de Preenchimento:"
                        lgr = lgr + 1
                        Sheets("FORMULARIO").Cells(lgr, 2) = Sheets("PLANILHA GERAL").Cells(lgp, 20)
                        
                        caracteres = Len(Sheets("FORMULARIO").Cells(lgr, 2))
                    
                        If caracteres > 130 Then 'Checa quantidade de caracteres para quebrar frase em outra linha
                            Range(Cells(lgr, 2), Cells(lgr + Int(caracteres / 130), 10)).Select
                            With Selection
                                .MergeCells = True
                                .WrapText = True
                                .HorizontalAlignment = xlLeft
                                .VerticalAlignment = xlTop
                            End With
                        End If
                             
                        lgr = lgr - 1
                        lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag  'checa se definicao do item ficou em duas paginas
                        While lrest < (1 + Int(caracteres / 130 + 0.999999))
                            Rows(lgr).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            lgr = lgr + 1
                            lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                            
                        Wend
                             
                        lgr = lgr + 2 + Int(caracteres / 130)
                        
                    End If
                           
                End If
            
                If ultimalinha = True Then 'Checa se e a ultima linha de uma pergunta
            
                    If Sheets("PLANILHA GERAL").Cells(lgp, 21) <> "" Then 'Gera definição do item
                        Sheets("FORMULARIO").Cells(lgr, 1) = "- Definição do Item:"
                        lgr = lgr + 1
                        
                        Sheets("FORMULARIO").Cells(lgr, 2) = Sheets("PLANILHA GERAL").Cells(lgp, 21)
                        
                        caracteres = Len(Sheets("FORMULARIO").Cells(lgr, 2))
                    
                        If caracteres > 130 Then 'Checa quantidade de caracteres para quebrar frase em outra linha
                            Range(Cells(lgr, 2), Cells(lgr + Int(caracteres / 130), 10)).Select
                            With Selection
                                .MergeCells = True
                                .WrapText = True
                                .HorizontalAlignment = xlLeft
                                .VerticalAlignment = xlTop
                            End With
                        End If
                             
                        lgr = lgr - 1
                        lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag  'checa se definicao do item ficou em duas paginas
                        While lrest < (1 + Int(caracteres / 130 + 0.999999))
                            Rows(lgr).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                            lgr = lgr + 1
                            lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                            
                        Wend
                    
                        lgr = lgr + 2 + Int(caracteres / 130)
                    
                        lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag 'Checa posicao antes de gerar o comentario, para nao ficar dividido em duas paginas
                    
                        While lrest < 4
                            lgr = lgr + 1
                            lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
                        Wend
                        
                        Sheets("FORMULARIO").Cells(lgr, 1) = "- Comentários do Agente:" 'Gera comentario
                        lgr = lgr + 1
                        Range(Cells(lgr, 1), Cells(lgr + 2, 10)).Select
            
                        With Selection
                            .MergeCells = True
                            .WrapText = True
                        End With
                        With Selection.Borders(xlEdgeLeft)
                            .LineStyle = xlContinuous
                        End With
                        With Selection.Borders(xlEdgeTop)
                            .LineStyle = xlContinuous
                        End With
                        With Selection.Borders(xlEdgeBottom)
                            .LineStyle = xlContinuous
                        End With
                        With Selection.Borders(xlEdgeRight)
                            .LineStyle = xlContinuous
                        End With
                        lgr = lgr + 4
                
                    End If
                End If
            End If
        Next lgp
    
    'FIM - DECLARACAO
    
        lrest = (Int((lgr - 1) / linha_pag + 0.99999) - (lgr - 1) / linha_pag) * linha_pag
        lgr = lgr + lrest
        Application.Goto Reference:="fim"
        Selection.Copy
        Sheets("FORMULARIO").Activate
        Cells(lgr, 1).Select
        
        ActiveSheet.Paste
    
    ' DEFINE AREA DE IMPRESSAO
        area_imp = "$A$1:$J$" & (lgr + 27)
        ActiveSheet.PageSetup.PrintArea = area_imp
    
        
        resposta = MsgBox("RELATÓRIO GERADO COM SUCESSO!", vbOKOnly, "ANEEL/SFG") 'Gera aviso de CONCLUSAO DO RELATORIO
        
        Application.ScreenUpdating = True 'descongela atualizacao de pagina
        Application.EnableEvents = True
        ActiveSheet.DisplayPageBreaks = True
        
    End Sub
    
    

    sábado, 28 de dezembro de 2013 21:11
  • Boa noite Tusallum.

    Primeiramente, pelo menos para mim, é estranho tempos tão discrepantes entre as versões do Excel, isso não faz muito sentido. Os Hardwares onde estão instalados são similares? Se estiverem instalados juntos no mesmo SO isso pode ser uma possível causa. No meu caso, eu sempre percebo diferenças na execução, mas sempre a favor do 2010 (mesmo para tarefas simples).

    Apenas olhando seu código, sem depurar num caso real, fica difícil dizer onde estão os gargalos, mas de toda forma eu sugiro algumas verificações:

    • Nos meus códigos percebi que manter outras pastas de trabalho abertas que não tem relação com o código afeta significativamente a execução (feche tudo do Excel que não for necessário).
    • Pra ser mais claro, as vezes fechando todo o Excel e abrindo apenas a pasta de trabalho de interesse (sem abrir o Editor VBA) melhora visivelmente a execução.
    • Você está usando muito o 'Select'. Geralmente suprimir essa parte não faz falta alguma (ScreenUpdating = False) e melhora o desempenho.
    • Você está inserindo muitas linhas e com formatação: isso é realmente necessário?
    • Copiar com formatação também é uma operação mais lenta. Elas são necessárias? Tente formatar toda a planilha com o estilo padrão e depois altere apenas os locais necessários.

    Não sei se consigo te ajudar apenas com essa dicas, mas qualitativamente é o que consigo apontar.

    Ah, outra coisa: usar

    Dim celula, area_imp As String

    define apenas 'area_imp' como 'String'! 'celula' fica como 'Variant'. Tem que declarar uma a uma.

    Espero que ajude.

    Um abraço.


    Filipe Magno



    sábado, 28 de dezembro de 2013 22:05
  • Adicionando mais comoentários em cima do que o Felipe falou:

    Não atualize a sua barra de progresso a cada iteração do seu laço. Por que não fazer uma atualização gráfica apenas de 10 em 10 itens? Troque:

    Application.StatusBar = lgp / (Range("maior") + 1) * 100 & " % do Relatório Gerado" 'cria barra para acompanhamento da macro

    por:

    If lgp Mod 10 = 0 Then
      Application.StatusBar = lgp / (Range("maior") + 1) * 100 & " % do Relatório Gerado" 'cria barra para acompanhamento da macro
    End If

    ---

    Experimente, além de desabilitar a propriedade ScreenUpdating, mudar a forma de cálculo do Excel. Para ganhar mais velocidade:

    Application.Calculation = xlCalculationManual

    Para voltar ao padrão do Excel:

    Application.Calculation = xlCalculationAutomatic

    ---

    Na minha opinião, o que torna a rotina demorada é a criação de objetos CheckBox. No entanto, você deve criar várias caixas de seleção, não é? Nesse caso, não tem jeito de sugerir algo diferente.


    Felipe Costa Gualberto - http://www.ambienteoffice.com.br

    sábado, 28 de dezembro de 2013 22:58
    Moderador
  • Filipe e Felipe, obrigado pelas dicas!!

    Já as implementei (além de outras também) para aumentar a performance do programa e acho que já cheguei próximo ao limite possível. Está demorando 15 minutos para rodar, antes estava levando horas, portanto considero que tive um bom resultado.

    Continuo sem entender o porque da diferença entre o 2007 e o 2010 (na mesma máquina, com uma versão por vez instalada).

    De qualquer forma agradeço.

    domingo, 29 de dezembro de 2013 02:57