[Resolvido] acOutputForm

[Julien.Sorel 0]

Olá Pessoas,

 

Uma pequena ajuda... Gostaria de exportar 3 tabelas diferentes para um mesmo arquivo Excel; porém quando uso o TransferSpreadsheet a infomação não é formatada e quando uso o acOutputForm não consigo exportar estas 3 forms* para o mesmo arquivo.

 

*A opção pelo form se deu pela necessidade de alterar o nome dos campos nas querys - optei por alterar diretamente no form, apenas uma vez.

 

Abaixo segue a linha de comando com o TransferSpreadsheet funcionando e com acOutputForm que gostaria que funcionasse.

 

PS: não é precisso, nessariamente que seja mantido este fluxo, o principal objetivo é:

 

* Exportar 3 consultas para um mesmo arquivo Excel;

* Em 3 sheets diferentes;

* Com uma formatação simples, mas que não seja a padrão - tosca - feita pelo Office.

 

----------

Function ExpResultado()

Dim strPasta As Object

Dim strExportar, strArquivo, strTitle, strTransf As String

Dim strForm1, strForm2, strForm3, strForm4 As String

 

strForm1 = "frmPedidos"

strForm2 = "frmPedidos2"

strForm3 = "frmPedidos3"

strForm4 = "frmPedidos4"

 

On Error GoTo Err_Resultado

 

Set strPasta = VBA.CreateObject("Scripting.FileSystemObject")

 

'Informa o nome da pasta que o arquivo será criado

strExportar = CurrentProject.Path & "\Report Export\"

 

'Caso não exista a pasta, ele cria

If Not strPasta.FolderExists(strExportar) Then MkDir strExportar

 

'Informa o nome do arquivo Excel

strArquivo = strExportar & "Pedidos " & StrConv(Left(MonthName(Month(Date)), 3), 1) & ".xls"

 

'Verificar se já existe algum arquivo com o mesmo nome - caso sim, ele substitui

If strPasta.FileExists(strExportar & "\" & strArquivo) Then

On Error Resume Next

VBA.Kill strExportar & "\" & strArquivo

If VBA.Err.Number <> 0 Then

Call strMsgErr

End If

End If

 

 

''Caso a idia fosse apenas exportar o conteúdo, este módulo estaria OK, mas a informação não é formatada no Excel...

 

'Transferir consulta para formato Excel

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "sqlPedidos", strArquivo, True, "Ped_10"

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "sqlPedidos2", strArquivo, True, "Ped_20"

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "sqlPedidos3", strArquivo, True, "Ped_30"

MsgBox "Informações exportadas com sucesso!" & vbLf & vbLf & strArquivo, vbInformation, "Sistema Access"

 

''Já usando o output form, consigo que ele saia no formato e com os nomes - alterei o nome dos labels - que quero

''Não quero ter de alterar todos os nomes dos campos na sql, por isso fiz apenas no form

 

'Transferir formulário para formato Excel

'DoCmd.OutputTo acOutputForm, strForm1, acSpreadsheetTypeExcel12, strArquivo, False

'DoCmd.OutputTo acOutputForm, strForm2, acSpreadsheetTypeExcel12, strArquivo, False

'DoCmd.OutputTo acOutputForm, strForm3, acSpreadsheetTypeExcel12, strArquivo, False

 

'Abrir arquivo exportado

Shell "explorer.exe " & strArquivo

 

Exit_Resultado:

Exit Function

 

Err_Resultado:

MsgBox "Erro número: " & Err.Number & vbLf & vbLf & Err.Description, vbCritical, "Sistema Access"

Resume Exit_Resultado

 

End Function

 

 

Agradecido desde já,

 

Julien Sorel

[Julien.Sorel 0]

Olá Pessoas,

 

Depois de algum tempo inventando possibilidades no VBA e gravando macros no Excel, consegui; aabixo segue solução...

 

**********************************************

 

Function ExpResultado()

Dim strPasta As Object

Dim strExportar As String, strArquivo As String, strTitle As String

Dim strSubPasta As String, strExcluir As String, strNmPasta As String

Dim strNmArquivo As String

 

''''De todo este comando, os pontos principais são três linhas que coloquei a referência < e >

'>

Dim oXLS As New Excel.Application

Dim oWKB As Workbook

'>

Dim strBegin, strEnd, strDif As Date

 

On Error GoTo Err_Resultado

strTitle = "Sistema"

strBegin = Now()

 

Set strPasta = VBA.CreateObject("Scripting.FileSystemObject")

 

'Informa o nome da pasta que o arquivo será criado

strNmPasta = CurrentProject.Path & "\Report Export"

strSubPasta = "\" & Year(Date) & Format(Month(Date), "00") & "_" & MonthName(Month(Date))

 

'Caso não exista a pasta, ele cria

If Not strPasta.FolderExists(strNmPasta) Then MkDir strNmPasta

If Not strPasta.FolderExists(strNmPasta & strSubPasta) Then MkDir strNmPasta & strSubPasta

strExportar = strNmPasta & strSubPasta

 

'Informa o nome do arquivo Excel

strNmArquivo = InputBox("Confirme o nome do arquivo!", strTitle, "Lista de Pedidos " & StrConv(Left(MonthName(Month(Date)), 3), 1))

strArquivo = strNmArquivo & "_TMP.xls"

 

'Exportar arquivo para o Excel

strExportar = strNmPasta & strSubPasta & "\" & strArquivo

 

'Verificar se já existe algum arquivo com o mesmo nome - caso sim, ele substitui

If strPasta.FileExists(strExportar & "\" & strArquivo) Then

On Error Resume Next

VBA.Kill strExportar & "\" & strArquivo

If VBA.Err.Number <> 0 Then

Call strMsgErr

End If

End If

 

DoCmd.Hourglass (True)

 

'Seleciona as consultas que deverão ser exportadas - e formata

DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, "UNION_15_DDF", strExportar, False, "15_DDF"

'<

Set oWKB = oXLS.Workbooks.Open(strExportar, False, False)

'>

GoTo Sheet_1

 

'-------------------------------------------------------------------------------------------------------------

'Nomear as colunas do arquivo Excel 1

Sheet_1:

oWKB.Worksheets(1).Range("A1").Cells.Value = "A"

oWKB.Worksheets(1).Range("B1").Cells.Value = "B"

oWKB.Worksheets(1).Range("C1").Cells.Value = "C"

oWKB.Worksheets(1).Range("D1").Cells.Value = "D"

oWKB.Worksheets(1).Range("E1").Cells.Value = "D"

oWKB.Worksheets(1).Range("F1").Cells.Value = "E"

oWKB.Worksheets(1).Range("G1").Cells.Value = "F"

oWKB.Worksheets(1).Range("H1").Cells.Value = "G"

oWKB.Worksheets(1).Range("I1").Cells.Value = "H"

oWKB.Worksheets(1).Range("J1").Cells.Value = "I"

oWKB.Worksheets(1).Range("K1").Cells.Value = "J"

oWKB.Worksheets(1).Range("L1").Cells.Value = "K"

oWKB.Worksheets(1).Range("M1").Cells.Value = "L"

oWKB.Worksheets(1).Range("N1").Cells.Value = "M"

oWKB.Worksheets(1).Range("O1").Cells.Value = "N"

oWKB.Worksheets(1).Range("P1").Cells.Value = "O"

oWKB.Worksheets(1).Range("Q1").Cells.Value = "P"

oWKB.Worksheets(1).Range("R1").Cells.Value = "Q"

oWKB.Worksheets(1).Range("S1").Cells.Value = "R"

oWKB.Worksheets(1).Range("T1").Cells.Value = "S"

oWKB.Worksheets(1).Range("U1").Cells.Value = "T"

oWKB.Worksheets(1).Range("V1").Cells.Value = "U"

oWKB.Worksheets(1).Range("W1").Cells.Value = "V"

oWKB.Worksheets(1).Range("X1").Cells.Value = "W"

oWKB.Worksheets(1).Range("Y1").Cells.Value = "X"

oWKB.Worksheets(1).Range("Z1").Cells.Value = "Z1"

oWKB.Worksheets(1).Range("AA1").Cells.Value = "ZZZ"

 

'Formatar planilha 1

oWKB.Worksheets(1).Range("A:AA").EntireColumn.Font.Name = "Calibri"

oWKB.Worksheets(1).Range("A:AA").EntireColumn.HorizontalAlignment = xlLeft

oWKB.Worksheets(1).Range("AB:AD").EntireColumn.ClearContents

oWKB.Worksheets(1).Range("F:F").EntireColumn.NumberFormat = "0"

oWKB.Worksheets(1).Range("J:K").EntireColumn.NumberFormat = "0.00%"

oWKB.Worksheets(1).Range("O:R").EntireColumn.NumberFormat = "0.00%"

oWKB.Worksheets(1).Range("I:I").EntireColumn.NumberFormat = "$ #,##0.00"

oWKB.Worksheets(1).Range("N:N").EntireColumn.NumberFormat = "$ #,##0.00"

oWKB.Worksheets(1).Range("S:AA").EntireColumn.NumberFormat = "$ #,##0.00"

oWKB.Worksheets(1).Range("A1:AA1").Font.Color = 0

oWKB.Worksheets(1).Range("A1:AA1").Interior.Color = 12301998

oWKB.Worksheets(1).Range("A:AA").EntireColumn.AutoFit

'-------------------------------------------------------------------------------------------------------------

 

DoCmd.Hourglass (False)

 

 

''Esta sequência abaixo deverá ser melhorada - "limpar"

 

'Fechamento do arquivo temporário do Excel

oXLS.Visible = False

oWKB.Save

 

'Verificar se já existe algum arquivo com o mesmo nome - caso sim, ele substitui

If strPasta.FileExists(strNmPasta & strSubPasta & "\" & strNmArquivo & ".xls") Then

On Error Resume Next

VBA.Kill strNmPasta & strSubPasta & "\" & strNmArquivo & ".xls"

If VBA.Err.Number <> 0 Then

Call strMsgErr

End If

End If

 

'Salvar arquivo Excel

oWKB.SaveAs strNmPasta & strSubPasta & "\" & strNmArquivo & ".xls", xlExcel5, , , False, False

 

VBA.Kill (strExportar)

 

'Identificação do arquivo backup .xlk criado

strExcluir = strNmPasta & strSubPasta & "\Backup of " & strNmArquivo & "_TMP.xlk"

oXLS.Quit

 

Set oXLS = Nothing

Set oWKB = Nothing

 

'Cálculo da duração do processamento

strEnd = Now()

strDif = strEnd - strBegin

 

'Exclusão do arquivo backup criado

VBA.Kill (strExcluir)

 

'Finalização do móduo

MsgBox "Informações exportadas com sucesso!" & vbLf & vbLf & strExportar & vbLf & _

vbLf & "Duração do processo: " & CDate(Format(strDif, "hh:mm:ss")), vbInformation, strTitle

 

Form_FrmMenu.Visible = True

DoCmd.Close acForm, "frmExport", acSaveYes

 

Exit_Resultado:

Exit Function

 

'Tratamento de erro, que finaliza Excel, "limpa" variáveis e retira ampulheta

Err_Resultado:

oXLS.Quit

Set oXLS = Nothing

Set oWKB = Nothing

strMsgErr

DoCmd.Hourglass (False)

 

Resume Exit_Resultado

 

End Function

 

 

 

Sem mais,

 

Julien Sorel