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


    [Resolvido]Optimização de código

    avatar
    zcarloslopes
    Intermediário
    Intermediário

    Respeito às Regras 100%

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

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

    Mensagem  zcarloslopes em 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
    Intermediário
    Intermediário

    Respeito às Regras 100%

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

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

    Mensagem  zcarloslopes em 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: 21/9/2019, 16:49