O codigo seria assim Option Explicit Dim oExcel As Object Dim objExlSht As Object Private Type ExlCell row As Long Col As Long End Type ------------------------------------- Private Sub cmd_Excel_Click() Dim objExlSht As Object Dim stCell As ExlCell MousePointer = vbHourglass ' Muda o ponteiro do mouse Set oExcel = CreateObject("Excel.Application") oExcel.Workbooks.Add 'inclui o workbook Set objExlSht = oExcel.ActiveWorkbook.Sheets(1) rs_Boletas_Lidas.MoveFirst ' Inclui os dados a partir da celula A9 stCell.row = 9 stCell.Col = 1 oExcel.Visible = True oExcel.Cells.Select 'Formata as células para Verdana 8 With Selection.Font .Name = "Verdana" .Size = 8 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With oExcel.Range("a2").Select oExcel.Range("a2") = "Empresas Reunidas JLP" oExcel.Range("b2").Select oExcel.Range("b2") = "Posição do Contrato: " & w_NumContr & " - " & w_NomeContr & " em " & Date oExcel.Range("b3") = w_Obs1 oExcel.Range("b4") = w_Obs2 oExcel.Range("b5") = w_Obs3 oExcel.Range("b6") = w_Obs4 oExcel.Range("b7") = w_Obs5 oExcel.Range("a2").Select ' Formata a coluna A Selection.ColumnWidth = 40 With Selection.Font .Name = "Verdana" .Size = 14 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = xlAutomatic End With ' Chama a Função CopiarTabelaExcel rs_Boletas_Lidas, objExlSht, stCell ' Salva a planilha objExlSht.SaveAs App.Path & "\Excel\" & Mid(w_NumContr, 1, 3) & Day(Date) & Month(Date) & ".xls" MsgBox "Planilha em Excel gerada!!!", vbInformation, "Manutenção de Boletas" objExlSht.Application.Quit Set objExlSht = Nothing ' remove a variavel objeto Set oExcel = Nothing ' remove a variavel objeto MousePointer = vbDefault cmd_Excel.Enabled = False End Sub Private Sub CopiarTabelaExcel(rs As Recordset, ws As Worksheet, StartingCell As ExlCell) Dim Vetor() As Variant Dim row As Long, Col As Long Dim fd As Field rs_Boletas_Lidas.MoveLast ReDim Vetor(rs_Boletas_Lidas.RecordCount + 1, I_parcelas) ' Copia as colunas do cabecalho para um vetor Vetor(row, Col) = "Nome / Vencimento" Col = Col + 1 dia = Val(Mid(d_Inicio, 1, 2)) mês = Val(Mid(d_Inicio, 4, 2)) ano = Val(Mid(d_Inicio, 7, 4)) row = 1 For JJ = 0 To I_parcelas - 1 Vetor(0, Col) = Format(d_Inicio, "dd/mm/yyyy") Col = Col + 1 mês = mês + 1 If mês > 12 Then mês = 1 ano = ano + 1 End If 'Verificando o mês de fevereiro If (mês = 2) Then If (dia >= 30) Then s_Data = "28" & "/" & Str(mês) & "/" & Str(ano) End If fevereiro = ano Mod 4 If (fevereiro <> 0) And (dia = 29) Then s_Data = "28" & "/" & Str(mês) & "/" & Str(ano) End If Else s_Data = Str(dia) & "/" & Str(mês) & "/" & Str(ano) End If d_Inicio = s_Data Next ' copia o recordset para um vetor rs_Boletas_Lidas.MoveFirst Col = 0 Do While Not rs_Boletas_Lidas.EOF w_Aluno = rs_Boletas_Lidas!N_Aluno Vetor(row, Col) = rs_Boletas_Lidas!N_Aluno Col = Col + 1 Do While w_Aluno = rs_Boletas_Lidas!N_Aluno If rs_Boletas_Lidas!Ocorrencia = "99" Then Vetor(row, Col) = " Cancelado " ElseIf rs_Boletas_Lidas!Ocorrencia = "03" Then Vetor(row, Col) = " Rejeitado " Else Vetor(row, Col) = IIf(IsNull(rs_Boletas_Lidas!Valor_Pg), " Não Pago ", rs_Boletas_Lidas!Valor_Pg) End If ' Vetor(row, Col) = IIf(IsNull(rs_Boletas_Lidas!DT_Vencimento), " Não Pago ", Format(rs_Boletas_Lidas!DT_Vencimento, "dd/mm/yyyy")) Col = Col + 1 rs_Boletas_Lidas.MoveNext If rs_Boletas_Lidas.EOF Then Exit Do End If Loop Col = 0 row = row + 1 Loop ws.Range(ws.Cells(StartingCell.row, StartingCell.Col), ws.Cells(StartingCell.row + rs.RecordCount + 1, _ StartingCell.Col + rs.Fields.Count)).Value = Vetor oExcel.Range("b9").Select ' Formata a Linha do Cabecalho oExcel.Range(Selection, Selection.End(xlToRight)).Select oExcel.Selection.ColumnWidth = 13 oExcel.Range("a9").Select oExcel.Range(Selection, Selection.End(xlToRight)).Select oExcel.Selection.Font.Bold = True oExcel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone oExcel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone oExcel.Selection.Borders(xlEdgeLeft).LineStyle = xlNone With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With oExcel.Selection.Borders(xlEdgeRight).LineStyle = xlNone oExcel.Selection.Borders(xlInsideVertical).LineStyle = xlNone oExcel.ActiveWindow.DisplayGridlines = False If oExcel.Range("a11") = Null Then oExcel.Range("b10").Select oExcel.Range(Selection, Selection.End(xlToRight)).Select Else oExcel.Range("b10").Select oExcel.Range(Selection, Selection.End(xlDown)).Select oExcel.Range(Selection, Selection.End(xlToRight)).Select End If With Selection .HorizontalAlignment = xlRight .VerticalAlignment = xlBottom .WrapText = False .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With If oExcel.Range("a11") = Null Then oExcel.Range("A10").Select Else oExcel.Range("A10").Select oExcel.Selection.End(xlDown).Select End If oExcel.Range(Selection, Selection.End(xlToRight)).Select oExcel.Selection.Borders(xlDiagonalDown).LineStyle = xlNone oExcel.Selection.Borders(xlDiagonalUp).LineStyle = xlNone oExcel.Selection.Borders(xlEdgeLeft).LineStyle = xlNone oExcel.Selection.Borders(xlEdgeTop).LineStyle = xlNone With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With oExcel.Selection.Borders(xlEdgeRight).LineStyle = xlNone oExcel.Selection.Borders(xlInsideVertical).LineStyle = xlNone With ActiveSheet.PageSetup 'Formata Impressao .PrintTitleRows = "" .PrintTitleColumns = "$A:$A" End With oExcel.ActiveSheet.PageSetup.PrintArea = "" With ActiveSheet.PageSetup .LeftHeader = "" .CenterHeader = "" .RightHeader = "" .LeftFooter = "" .CenterFooter = "" .RightFooter = "" .LeftMargin = Application.InchesToPoints(0.196850393700787) .RightMargin = Application.InchesToPoints(0.196850393700787) .TopMargin = Application.InchesToPoints(0.393700787401575) .BottomMargin = Application.InchesToPoints(0.393700787401575) .HeaderMargin = Application.InchesToPoints(0.511811023622047) .FooterMargin = Application.InchesToPoints(0.511811023622047) .PrintHeadings = False .PrintGridlines = False .PrintComments = xlPrintNoComments .PrintQuality = -4 .CenterHorizontally = False .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = 100 .PrintErrors = xlPrintErrorsDisplayed End With End Sub Como disse quando clico no botão cmd_Excel na primeira vez, a rotina está OK..... mas quando o excel é fechado e clico novamente, aparece o referido erro.