[Resolvido]Ao exportar consulta para o excel o campo hora perde a formatação

Boa tarde Feras.

Tenho um código VBA que executa a expostação de uma conslta para o Excel e funciona perfeitamente. Apenas um problema é gerado:
Os campos do tipo Data/Hora formatados como Hora Abreviada não mantém este formato na planilha obrigando o usuário a formatar as colunas com campos do tipo Hora.
Existe alguma forma de resolver esse problema?

O código que utilizo é este:

Private Sub Comando6_Click()

If IsNull([cboMêsRef]) Or IsEmpty([cboMêsRef]) Then
MsgBox "Ops !!! " & Chr(13) & "Você se esqueceu de selecionar o mês de referência. ", vbExclamation, " Atenção"
Me.cboMêsRef.SetFocus
DoCmd.CancelEvent

Else

Dim resultado As VbMsgBoxResult
resultado = MsgBox("Atenção: " & Chr(13) & "Você não selecionou uma Especialidade. " & Chr(13) & "Tem certeza que deseja prosseguir com esta ação?", vbYesNo, "Tomando uma decisão")
If resultado = vbYes Then
DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "qryExportação", "C:\BackMDB\MovimentoMensal" & ".xls", True
MsgBox "Operação completada. " & Chr(13) & "O Movimento do mês " & Me.cboMêsRef & " em sua totalidade " & Chr(13) & "foi exportado para o MS-Excel com sucesso. ", vbInformation, " InfoBasic Smart System"
Else
Me.cboEspecialidade.SetFocus
DoCmd.CancelEvent
End If
End If

End Sub

Abraços, WSenna

Dê uma pesquisada por "exportar para excel" que tem outras formas de exportação que permitem formatar campos antes da exportação.

Grande Rei WSenna, que bom vê-lo por aqui.

Amigão, esse comando DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, não leva formatação.

Eu utilizo um Excel já pré-fomatado, com este código exporta com nota 10, pode testar e espero que ajude;

A chamada da função, faço deste jeito:

Private Sub MeuBotão_Click()
Call ExportToExcelFormating("qryTeste", "Sheet1", "c:\teste.xls")
End Sub

Public Function ExportToExcelFormating(strQuery As String, strFolhaNome As String, strCaminhoTemplate As String)
'autor Bob Larson
    Dim rst As DAO.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As DAO.Field
    Dim strPath As String
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler


    strPath = strCaminhoTemplate

    Set rst = CurrentDb.OpenRecordset(strQuery)
    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Open(strPath)

    ApXL.Visible = True

    Set xlWSh = xlWBk.Worksheets(strFolhaNome)

    xlWSh.Activate
    xlWSh.Range("A1").Select

    For Each fld In rst.Fields
        ApXL.ActiveCell = fld.Name
        ApXL.ActiveCell.Offset(0, 1).Select
    Next

    rst.MoveFirst

    xlWSh.Range("A2").CopyFromRecordset rst

    xlWSh.Range("1:1").Select

    With ApXL.Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
    End With


    ApXL.Selection.Font.Bold = True

    With ApXL.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With

    ApXL.ActiveSheet.Cells.Select
    ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
    xlWSh.Range("A1").Select

    rst.Close

    Set rst = Nothing


Exit_ExportToExcelFormating:
    Exit Function


err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_ExportToExcelFormating
End Function

Fiz como sugeriu mas aparece uma mensagem do tipo:

3061
Parâmetros insuficientes. Eram esperados 1.

Amigão, coloque o Excel do exemplo em C:\ e teste;

Atenção à referência VBA Microsoft Excel 12.0 Object Library, eu estou no 2007, é só alterar para a sua.

https://dl.dropbox.com/u/771097/WSenna_Exporta.rar

Bom final de semana

Agora apresentou o erro:


430
Classe não oferece suporte a automação ou a interface esperada.


É véio, esse vício é fulminante. Depois que você toma uma dose de Access e VBA nunca mais se liberta e quer sempre mais.

Abraços, WSenna

PS. Troquei minha referência para Microsoft Excel 11.0 Object Library

Meu amigo, isso só acontece se tiver o Excel 97, ele não suporta o copyrecordset em DAO, temos de mudar para o ADODB

Marque a referencia VBA "Microsoft ActiveX Data Objects 2.x Library"

Agora teste assim;

Public Function ExportToExcelFormating(strQuery As String, strFolhaNome As String, strCaminhoTemplate As String)
'autor Bob Larson
    Dim rst As New ADODB.Recordset
    Dim ApXL As Object
    Dim xlWBk As Object
    Dim xlWSh As Object
    Dim fld As ADODB.Field
    Dim strPath As String
    Dim strSql As String
    Const xlCenter As Long = -4108
    Const xlBottom As Long = -4107
    On Error GoTo err_handler


    strPath = strCaminhoTemplate
strSql = "Select * from qryTeste"
rst.Open strSql, CurrentProject.Connection

    'Set rst = CurrentDb.OpenRecordset(strQuery)
    Set ApXL = CreateObject("Excel.Application")
    Set xlWBk = ApXL.Workbooks.Open(strPath)

    ApXL.Visible = True

    Set xlWSh = xlWBk.Worksheets(strFolhaNome)

    xlWSh.Activate
    xlWSh.Range("A1").Select

    For Each fld In rst.Fields
        ApXL.ActiveCell = fld.Name
        ApXL.ActiveCell.Offset(0, 1).Select
    Next

    rst.MoveFirst

    xlWSh.Range("A2").CopyFromRecordset rst

    xlWSh.Range("1:1").Select

    With ApXL.Selection.Font
        .Name = "Arial"
        .Size = 12
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
    End With


    ApXL.Selection.Font.Bold = True

    With ApXL.Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .MergeCells = False
    End With

    ApXL.ActiveSheet.Cells.Select
    ApXL.ActiveSheet.Cells.EntireColumn.AutoFit
    xlWSh.Range("A1").Select

    rst.Close

    Set rst = Nothing


Exit_ExportToExcelFormating:
    Exit Function


err_handler:
    DoCmd.SetWarnings True
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_ExportToExcelFormating
End Function

Agora a mensagem é:

-2147319779
O método 'CopyFromRecordset' do objeto 'Range' falhou.

A planilha até abre com o cabeçalho dos campos preenchidos mas os valores das células não contem os valores.
Detalhe, o meu Excel é 2003.

WSenna

Uma pergunta, isso está a acontecer no exemplo .mdb e no Excel que eu anexei aqui ?

Aqui não devolve qualquer erro e utilizo no trabalho em varios departamentos e nunca surgiu erro algum.

No aguardo

... exatamente.

Criei uma pasta C:\Teste e descompactei seu exemplo para ela, tanto o mdb quanto a planilha.

Já estudei o código linha por linha mas não descobri onde pode estar ocorrendo o problema.

Como dizia meu saudoso Pai, "A guarda morre mas não se rende." vou continuar a batalha, tem que dar certo.

Abraços, WSenna

Meu velho amigo.
Eu deixei o mdb no desktop, e o Excel direto em c:\, nao criei pasta alguma e funfa beleza.

Grande JPaulo, boa tarde.

Me intriga este trexo do código:

'Set rst = CurrentDb.OpenRecordset(strQuery)
Set ApXL = CreateObject("Excel.Application")
Set xlWBk = ApXL.Workbooks.Open(strPath)

Não seria essa aspa simples que esteja bloqueando a cópia?

Abraços, WSenna

Na consulta para exportação criei uma formatação para os campos Data/Hora do tipo InícioAnestesia: Formato([IniAnest];"hh:mm") e assim para os demais. Sei que desta forma transformei o campo Data/Hora em Texto, contudo, no ato de exportar a planilha recebe a informação formatada como "hora abreviada" de mentirinha.

A consulta ficou assim:

SELECT Cirurgias.Ano, Cirurgias.Mês, Cirurgias.Especialidade, Movimento.DataPrevista AS [Data Prevista], Format([HraProg],"hh:mm") AS [Hora Programada], IIf([HraProg] Is Null,"",IIf([HraProg]>=#12/30/1899 12:1:0# And [HraProg]<#12/30/1899 18:0:0#,"Tarde",IIf([HraProg]>=#12/30/1899 2:1:0# And [HraProg]<=#12/30/1899 12:0:0#,"Manhã","Noite"))) AS Período, Movimento.DataCir AS [Data da Cirurgia], Movimento.Prontº AS Prontuário, Movimento.Paciente AS [Nome do Paciente], Movimento.Sexo, Movimento.DNasc AS [Data de Nascimento], Movimento.Idade AS [Idade Detalhada], Movimento.Enfermarias, Movimento.Diagnóstico, Movimento.CID AS [Código CID], Movimento.Procedimento, Movimento.Tipo, Format([HRecep],"hh:mm") AS [Chegada ao CC], Format([HSala],"hh:mm") AS [Na SO], Format([InícioAnest],"hh:mm") AS [Início da Anestesia], Format([Início],"hh:mm") AS [Início da Cirurgia], Format([Final],"hh:mm") AS [Final da Cirurgia], Format([FinalAnest],"hh:mm") AS [Final da Anestesia], Format([SaídaCC],"hh:mm") AS [Saída do CC], Movimento.Cirurgião, Movimento.Anestesista, Movimento.Anestesia, Movimento.Intercorrências, Movimento.Motivo, Movimento.Descrição, Movimento.Justificado
FROM Cirurgias INNER JOIN Movimento ON Cirurgias.Código = Movimento.Código
WHERE (((Cirurgias.Especialidade) Like [Forms]![frmExportação]![cboEspecialidade] & "*") AND ((Cirurgias.MêsRef)=[Forms]![frmExportação]![cboMêsRef]))
ORDER BY Cirurgias.Ano, Cirurgias.Numeral, Cirurgias.Especialidade;

A planilha ficou assim: http://dl.dropbox.com/u/1378556/MovimentoMensal.xls


Não quer dizer que desisti de fazer a coisa correta, mas ...

Abraços, WSenna

Grande, essa aspa simples está a comentar um trecho de codigo que só fazia falta na abertura do recordset por DAO, como passei no inicio.