MaximoAccess

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

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração


Participe do fórum, é rápido e fácil

MaximoAccess

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

https://www.maximoaccess.com/t48-regras-do-forum

Obrigado

Administração

MaximoAccess

Gostaria de reagir a esta mensagem? Crie uma conta em poucos cliques ou inicie sessão para continuar.

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

    [Resolvido]Optimização de código

    avatar
    zcarloslopes
    Avançado
    Avançado

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 382
    Registrado : 28/10/2010

    [Resolvido]Optimização de código Empty [Resolvido]Optimização de código

    Mensagem  zcarloslopes 28/3/2019, 11:30

    Bom dia,

    Venho pedir ajuda para o seguinte:

    Tenho um código (abaixo) que exporta uma consulta para excel e formata alguns campos para que o ficheiro excel fique pronto a enviar por mail.
    Este código funciona a maioria das vezes, mas de quando em quando dá um erro: Run-time error 91: Object variable or With block not set, e ao compilar o código não dá qualquer erro. O VBA não é de longe o meu forte, como tal não consigo ver onde poderá estar este erro.

    Sempre que dá erro aparece na seguinte linha:
    Código:
    ActiveSheet.Range("A1").Select
    Código:
    Código:
    Dim Diretorio As String
    Dim objExcel As Object
    Dim mysheet As Object

    'Merge Cells same Column value
    '-----------------------------------------------------------------------------------
    Dim varTestVal As Variant
    Dim intRowCount As Integer
    Dim intAdjustment As Integer
    '-----------------------------------------------------------------------------------

    Diretorio = Environ$("USERPROFILE") & "\Ambiente de trabalho\Dados_Exportados.xls"
        DoCmd.TransferSpreadsheet acExport, 8, _
        "cst_Teste1", Diretorio, False, "A1:M1"
          
        Set objExcel = CreateObject("Excel.Application")
        Set mysheet = objExcel.Workbooks.Open(Diretorio)
            With mysheet
                .Activate
                .Sheets(1).Select
                .Sheets(1).Range("A1") = "RefªSEFT"
                .Sheets(1).Range("B1") = "Serviço Destino"
                .Sheets(1).Range("C1") = "Nome da Instituição"
                .Sheets(1).Range("D1") = "Nome do Estágio"
                .Sheets(1).Range("E1") = "Nº de Estágios Pedidos"
                .Sheets(1).Range("F1") = "Nº de Estágios Autorizados"
                .Sheets(1).Range("G1") = "Data de Início"
                .Sheets(1).Range("H1") = "Data de Fim"
                .Sheets(1).Range("I1") = "Ano Escolar"
                .Sheets(1).Range("J1") = "Nome do Aluno(Completo)"
                .Sheets(1).Range("K1") = "Nome do 1º Orientador"
                .Sheets(1).Range("L1") = "Nome do 2º Orientador"
                .Sheets(1).Range("M1") = "Nota Final"
                
                .Sheets(1).Columns("A").ColumnWidth = 10
                .Sheets(1).Columns("B:F").ColumnWidth = 20
                .Sheets(1).Columns("G:I").ColumnWidth = 15
                .Sheets(1).Columns("J:L").ColumnWidth = 35
                .Sheets(1).Columns("M").ColumnWidth = 10
                
                .Sheets(1).Range("A1:M1").Font.Bold = True

                .Sheets(1).Range("A1:M1").Interior.ColorIndex = 20
                
                .Sheets(1).Range("B2:D50").WrapText = True 'Justifica Texto
                
                .Sheets(1).Range("A1:M1").Borders.LineStyle = xlContinuous
                
                .Sheets(1).Range("E2:M50").RowHeight = 25
                
                    '-----------------------------------------------------------------------------------
                    'Merge Cells same Column value - Column(A)
                    '-----------------------------------------------------------------------------------
                    ActiveSheet.Range("A1").Select
                    'Find like values in column A - Merge and Center Cells
                    While Selection.OFFSET(1, 0).Value <> ""
                     'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
                        intRowCount = 1
                        varTestVal = Selection.Value
                        While Selection.OFFSET(1, 0).Value = varTestVal
                            intRowCount = intRowCount + 1
                            Selection.OFFSET(1, 0).Select
                            Selection.ClearContents
                        Wend
                        intAdjustment = (intRowCount * -1) + 1
                        Selection.OFFSET(intAdjustment, 0).Select
                        Selection.Resize(intRowCount, 1).Select
                        With Selection
                            .Merge
                            .HorizontalAlignment = xlLeft
                            .VerticalAlignment = xlCenter
                        End With
                        Selection.OFFSET(1, 0).Resize(1, 1).Select
                    Wend
                    '------------------------------------------------------------------------------------------
                    'Merge Cells same Column value - Column(B)
                    '-----------------------------------------------------------------------------------
                    ActiveSheet.Range("B1").Select
                    'Find like values in column A - Merge and Center Cells
                    While Selection.OFFSET(1, 0).Value <> ""
                     'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
                        intRowCount = 1
                        varTestVal = Selection.Value
                        While Selection.OFFSET(1, 0).Value = varTestVal
                            intRowCount = intRowCount + 1
                            Selection.OFFSET(1, 0).Select
                            Selection.ClearContents
                        Wend
                        intAdjustment = (intRowCount * -1) + 1
                        Selection.OFFSET(intAdjustment, 0).Select
                        Selection.Resize(intRowCount, 1).Select
                        With Selection
                            .Merge
                            .HorizontalAlignment = xlLeft
                            .VerticalAlignment = xlCenter
                        End With
                        Selection.OFFSET(1, 0).Resize(1, 1).Select
                    Wend
                    '------------------------------------------------------------------------------------------
                    'Merge Cells same Column value - Column(C)
                    '-----------------------------------------------------------------------------------
                    ActiveSheet.Range("C1").Select
                    'Find like values in column A - Merge and Center Cells
                    While Selection.OFFSET(1, 0).Value <> ""
                     'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
                        intRowCount = 1
                        varTestVal = Selection.Value
                        While Selection.OFFSET(1, 0).Value = varTestVal
                            intRowCount = intRowCount + 1
                            Selection.OFFSET(1, 0).Select
                            Selection.ClearContents
                        Wend
                        intAdjustment = (intRowCount * -1) + 1
                        Selection.OFFSET(intAdjustment, 0).Select
                        Selection.Resize(intRowCount, 1).Select
                        With Selection
                            .Merge
                            .HorizontalAlignment = xlLeft
                            .VerticalAlignment = xlCenter
                        End With
                        Selection.OFFSET(1, 0).Resize(1, 1).Select
                    Wend
                    '------------------------------------------------------------------------------------------
                    'Merge Cells same Column value - Column(D)
                    '-----------------------------------------------------------------------------------
                    ActiveSheet.Range("D1").Select
                    'Find like values in column A - Merge and Center Cells
                    While Selection.OFFSET(1, 0).Value <> ""
                     'If instead you have blanks in the column, change the prev statement to While Selection.Offset(1, 0).Value <> "." and add "." to the last 2 rows of the data
                        intRowCount = 1
                        varTestVal = Selection.Value
                        While Selection.OFFSET(1, 0).Value = varTestVal
                            intRowCount = intRowCount + 1
                            Selection.OFFSET(1, 0).Select
                            Selection.ClearContents
                        Wend
                        intAdjustment = (intRowCount * -1) + 1
                        Selection.OFFSET(intAdjustment, 0).Select
                        Selection.Resize(intRowCount, 1).Select
                        With Selection
                            .Merge
                            .HorizontalAlignment = xlLeft
                            .VerticalAlignment = xlCenter
                        End With
                        Selection.OFFSET(1, 0).Resize(1, 1).Select
                    Wend
                    '------------------------------------------------------------------------------------------
                .Save
            End With
        objExcel.Quit
        Set mysheet = Nothing
        Set objExcel = Nothing
    Alguém me poderia dar uma ajuda a optimizar o código para deixar de aparecer o erro?

    Obrigado


    Última edição por zcarloslopes em 28/3/2019, 16:35, editado 1 vez(es)
    avatar
    zcarloslopes
    Avançado
    Avançado

    Respeito às regras : Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 382
    Registrado : 28/10/2010

    [Resolvido]Optimização de código Empty Re: [Resolvido]Optimização de código

    Mensagem  zcarloslopes 28/3/2019, 16:34

    Obrigado a todos,

    Sem saber muito bem a razão, consegui resolver o problema.
    Entretanto confirmei que o problema ocorria sempre na segunda tentativa de execução do código.

    Então substitui as linhas que continham as expressões:
    Código:
    ...
    ActiveSheet.Range("A1").Select
    ...
    While Selection...
    ...
    Selection...
    ...
    por:
    Código:
    ...
    objExcel.Range("A1").Select
    ...
    While objExcel.Selection...
    ...
    objExcel.Selection...
    ...
    Agora funciona sem qualquer erro.

    Obrigado

      Data/hora atual: 1/8/2021, 11:04