Usamos cookies para medir audiência e melhorar sua experiência. Você pode aceitar ou recusar a qualquer momento. Veja sobre o iMasters.
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
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