[Resolvido]Optimização de código

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

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