[Resolvido]Exportar para formulário modelo de Excell

Como raramente necessito de trabalhar com o Excell, surgiu-me um grande problema, espero que consigam ajudar.
Estou a criar um formulário access com subformulário que no fim do mês tem de ser exportado para o Excell, o problema é que o documento de Excell já está criado, tenho de colocar lá os campos do formulário mais os do subformulário continuo nos campos específicos, esse é que é o grande problema.
Segue anexos para poderem ver. Obrigado a todos os que puderem ajudar.

Boas....passo pelo mesmo problema...vou seguir o tópico !

Ok até copiar a primeira linha do formulário continuo já consegui fazer, não consegui foi que copiasse todos os registos do formulário continuo.

Nuno, boa noite a si.

Veja o que o Avelino Sampaio tem no site dele...
usandoaccess.com.br/dicas/manipular-planilha-excel-com-recordset.asp

Código:

Public Sub fncATualizarPlanilha()
Dim strTabela As String
Dim strSQL As String
Dim bdExcel As DAO.Database
Dim rs As DAO.Recordset
'Passa o local e nome do arquivo para a variável
strArquivo = CurrentProject.Path & "\ListaClientes.xls"
'Abre arquivo ListaClientes.xls
Set bdExcel = OpenDatabase(strArquivo,False,False,"Excel 12.0;HDR=Yes;IMEX=0;")
'Monta a consulta do Recordset
strSQL = "SELECT * FROM [Planilha1$]"
'Abre o Recordset da consulta
Set rs = bdExcel.OpenRecordset(strSQL)
'Adiciona novo produto à lista
rs.AddNew
   rs!id = 6
   rs!Produto = "Tesoura"
   rs![Valor Produto] = "18,70"
rs.Update
'fecha o Recordset
rs.Close
Set rs = Nothing
'Fecha o arquivo Excel
bdExcel.Close
Set bdExcel = Nothing
MsgBox "A planilha foi atualizada...", vbInformation, "Aviso"
End Sub

O nosso problemas está no Formulário continuo.  No meu caso, vou ter entre 1 linha e 50 linhas no Formulário continuo.   Nessa hora que o "bicho pega"
Teria eu penso, que haveria de ter um Loop no FrmContinuo incrementando a planilha.

A minha duvida está nesse tópico ainda aberto..
https://www.maximoaccess.com/t33512-exportar-o-que-esta-no-formulario-para-celulas-definidas-no-excel

Boas Silvio já conseguiste resolver?
Eu após alguns testes consegui fazer, como só necessito de meia dúzia de registos é fácil, basta seleccionar a linha antes de a copiar, poderá existir um código vba mais fácil mas foi da forma que consegui.
Se queres esperar que alguém te indique outro código deixo em aberto, se não dou o concluído, decide e diz.
Tentei o Loop mas não consegui.
Ora vê:

Boas Nuno....

É mais ou menos por ai...

Mantenha por gentileza o tópico aberto, vou tentar fazer umas mudanças entre hoje e segunda feira, pois estou meio que apertado aqui com um desenvolvimento.

Mas, o caminho está parecendo esse mesmo.

Abraços.

Ok

Nuno Boa tarde a si.

Como dizemos cá "deu ziza" !

Não estou conseguindo mover para o primeiro registro do meu subformulário !
O famoso erro 2046 " comando ou ação não disponível"

Código:

Forms!FrmPedido!SFrmDpedido.SetFocus
DoCmd.GoToRecord , , acFirst ' erro ocorre aqui

Já vi e revi...passei os olhos várias vezes em teu exemplo;   No seu o foco se move, mas no meu...." nem com reza braba"

A luta continua !!

Subformulário Modal?
Subformulário Popop?
Subformulário Ativo?
Se faz foco no Subformulário mas não vai para o 1.º registo deve ser do Subformulário, vê se não está bloqueado.
Vê as configurações do meu e tenta tanto no Subformulário em modo extrutura como no Subformulário dentro do formulário as propriedades podem ser diferentes e dá esse erro.

Agora que me lembro, acho que também me deparei com esse problema, resolução fácil.

muda

oExcel.Visible = True

para

oExcel.Visible = False

Quando abres o exel ele sobrepõe-se o que origina que o Windows o ponha como documento ativo e o access em segundo plano.
Se estiver oculto consegues dar a volta ao Bill Gates porque fica o access sempre em ativo.

Eu tive outro problema noutro painel que foi mais complicado quando acabei o código e mandei executar apareceu

vba - Procedure Too Large

Pesquisei o motivo e

Max 1,024 characters per line.
Max 6,601 lines per procedure.
Max 65,545 lines per module.
Max 1,000 modules per database.
Max 2 GB file size.

Resultado, tive de dividir o código em mais de duas dezenas porque era demasiado grande.

Legal......vou dar uma passada de olhos no meu subformulário.

A luta continua.....

Nuno, boa tarde.

Fiz algumas pequenas alterações no código fonte que me passou

Linha colocada antes da leitura do subformulário

Código:

    oExcel.CalculateBeforeSave = True ' Opcional, mas recomendado para grandes arquivos.

Linha acrescentada, ao terminar a exportação abre a planilha ( ficheiro ) do Ms Excel

Código:

  MsgBox "Exportação completa. Alterando  para a planilha do  Excel", vbInformation
     Set oBook = oExcel.workbooks.Open(Application.CurrentProject.Path & "\PN.xlsx")
     oExcel.Visible = True

Até o momento, já criei 21 linhas no MS Excel, espero não ter que criar mais.
Tanto, que criei um modulo de exportação para evitar lentidão e ser mais fácil para manutenção.

Acredito que, agora podemos dar o tópico por encerrado.

Abraços.

Boa tarde,

Código:

Private Sub CmdExportaExcel_Click()
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '  código criado por Alexandre Neves, do Fórum MaximoAccess  '
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim RstFrm As DAO.Recordset, RstSubFrm As DAO.Recordset, L As Integer
    Dim MeuExcel As Object, Folha
    'Passa o local e nome do arquivo para a variável
    'Abre arquivo ListaClientes.xls
    Set MeuExcel = CreateObject("Excel.Application")
    MeuExcel.Visible = False
    MeuExcel.Workbooks.Open FileName:=CurrentProject.Path & "\AssistDoença.xlsx"
   
    MeuExcel.Visible = True
    Set RstFrm = Me.RecordsetClone
    RstFrm.MoveFirst

    Do While Not RstFrm.EOF
        MeuExcel.range("G6") = RstFrm("MesDoc")
        MeuExcel.range("G7") = RstFrm("AnoDoc")
        MeuExcel.range("B19") = RstFrm("Saida")
        MeuExcel.range("F20") = RstFrm("DespachoQuem")
        MeuExcel.range("F21") = RstFrm("DespachoQuem1")
        RstFrm.MoveNext
    Loop

    Set RstSubFrm = Me!MêsDoc_Sub.Form.RecordsetClone
    RstSubFrm.MoveFirst
    L = 9
    Do While Not RstSubFrm.EOF
        L = L + 1
        MeuExcel.range("B" & L) = RstSubFrm("NumeroReceita")
        MeuExcel.range("C" & L) = RstSubFrm("DataReceita")
        MeuExcel.range("D" & L) = RstSubFrm("Doente")
        MeuExcel.range("E" & L) = RstSubFrm("Médico")
        MeuExcel.range("F" & L) = RstSubFrm("ValorReceita")
        MeuExcel.range("G" & L) = RstSubFrm("ObsReceita")
        RstSubFrm.MoveNext
    Loop
   
    'Fecha o arquivo Excel
    MeuExcel.ActiveWorkbook.Close SaveChanges:=True
    MeuExcel.Visible = True: MeuExcel.Quit: Set MeuExcel = Nothing
    Set RstFrm = Nothing
    Set RstSubFrm = Nothing
    MsgBox "A planilha foi atualizada...", vbInformation, "Aviso"
End Sub

Grande Alexandre Neves.... vou testar a tua solução.
Como eu disse ao Nuno, vou ter entre 10 a 50 registros no subformulário para serem exportados ao MS Excel.
Abraços.

Alexandre Neves, boa tarde a si !

Deu erro na rotina que postou.

Ela, está copiando todos os formulários e não o que está ativo na tela.

Fiz o teste apenas com os dados do formulário principal ( testando por partes ).

Adição....

Veja o código meu como ficou...um pouco diferente do que postou...

Código:

Private Sub bt_exportarPN_Click()
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
      'código criado por Alexandre Neves, do Fórum MaximoAccess  '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim RstFrm As DAO.Recordset, RstSubFrm As DAO.Recordset, L As Integer
    Dim MeuExcel As Object, Folha
    'Passa o local e nome do arquivo para a variável
    'Abre arquivo ListaClientes.xls
    Set MeuExcel = CreateObject("Excel.Application")
    MeuExcel.Visible = False
    MeuExcel.Workbooks.Open FileName:=CurrentProject.Path & "\PN.xlsx"
   
    MeuExcel.Visible = True
    Set RstFrm = Me.RecordsetClone
    RstFrm.MoveFirst

  ' Dados formulário principal
    Do While Not RstFrm.EOF
        MeuExcel.Range("H6") = RstFrm("cliente")
        MeuExcel.Range("H7") = RstFrm("NomeFantasia")
        MeuExcel.Range("H8") = RstFrm("CNPJ")
        MeuExcel.Range("N8") = RstFrm("InscrEstadual")
        MeuExcel.Range("H9") = RstFrm("endereco") & " ," & RstFrm("Numero")
        MeuExcel.Range("N9") = RstFrm("Bairro")
        MeuExcel.Range("H10") = RstFrm("Cidade")
        MeuExcel.Range("N10") = RstFrm("Estado")
        MeuExcel.Range("P10") = RstFrm("CEP")
        MeuExcel.Range("H11") = RstFrm("Fone")
        MeuExcel.Range("N11") = RstFrm("Celular")
        MeuExcel.Range("H12") = RstFrm("EmailNF")
        MeuExcel.Range("H13") = RstFrm("Prazoculta")
        MeuExcel.Range("N12") = RstFrm("ContatoCliente")
        MeuExcel.Range("O5") = RstFrm("DataPed")
        MeuExcel.Range("O15") = RstFrm("VendedorOculta")
        MeuExcel.Range("H15") = RstFrm("Observacao")
        MeuExcel.Range("N14") = RstFrm("DescT")
        MeuExcel.Range("H14") = RstFrm("FOculta")
        MeuExcel.Range("L5") = RstFrm("NossoPedido")
       
        RstFrm.MoveNext
    Loop
   
' Dados subformulário
    Set RstSubFrm = Me!SFrmDpedido.Form.RecordsetClone
    RstSubFrm.MoveFirst
    L = 18                  ' Uma celula(celula onde está o texto)antes da inserção.
    Do While Not RstSubFrm.EOF
        L = L + 1
        MeuExcel.Range("A" & L) = RstSubFrm("441")
        MeuExcel.Range("B" & L) = RstSubFrm("462")
        MeuExcel.Range("C" & L) = RstSubFrm("483")
        MeuExcel.Range("D" & L) = RstSubFrm("504")
        MeuExcel.Range("E" & L) = RstSubFrm("526")
        MeuExcel.Range("F" & L) = RstSubFrm("568")
        MeuExcel.Range("G" & L) = RstSubFrm("2GG10")
        MeuExcel.Range("H" & L) = RstSubFrm("3GG12")
        MeuExcel.Range("I" & L) = RstSubFrm("4GG14")
        MeuExcel.Range("J" & L) = RstSubFrm("16")
        MeuExcel.Range("K" & L) = RstSubFrm("18")
        MeuExcel.Range("L" & L) = RstSubFrm("Qtd")

        RstSubFrm.MoveNext
    Loop

    'Fecha o arquivo Excel
    MeuExcel.ActiveWorkbook.Close SaveChanges:=True
    MeuExcel.Visible = True: MeuExcel.Quit: Set MeuExcel = Nothing
    Set RstFrm = Nothing
    Set RstSubFrm = Nothing
    MsgBox "A planilha foi atualizada...", vbInformation, "Aviso"


End Sub

Boa tarde para si também
Vejo que vai buscar os primeiros dados ao form corrente e vai buscar os segundos dados ao subform SFrmDpedido
Este subform está dentro do form activo?
Mande exemplo de erro para se ver

Salve !

Sim tanto o formulário ( FrmPedido ) quanto o subformulário ( SFrmDpedido ) são ativos.

Ambos são " linkados " pelo CodPed ( Campo mestre  ) e no SFrmDpedido CodSubped (Campo Filho).

Quanto ao exemplo ora pedido, vai ser complicado lhe mandar, pois atrelado ao formulário principal tenho 4 tabelas e duas consultas.

Agradeço de antemão a vossa ajuda.

Abraços.

Mas os dados que vi no form e subform foram os dados passados para o excel. Não vi outros

Exato...são esses dados que devem ser passados ao Ms Excel.
O que ocorre é que está pegando todos os formulários e subformulários que estão nas respectivas tabelas.
Ou seja, está indo tudo e não aquele que está ativo no momento ( Frm e SubFrm )

É muito estranho e não vejo no código onde possa ir buscar dados a outros forms, mas seria necessário ter exemplo para análise

Alexandre, não tem como eu te mandar uma MP com o sistema ?
Devido a dados reais não posso colocar o link aqui.
Tem alguma outra forma ?

Boa noite, Sílvio
A diferença é que o form principal carrega vários registos e não 1 como parecia indicar
Use este código

Código:

Private Sub bt_exportarPN_Click()
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '  código criado por Alexandre Neves, do Fórum MaximoAccess  '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim RstFrm As DAO.Recordset, RstSubFrm As DAO.Recordset, L As Integer
    Dim MeuExcel As Object, Folha
    Set MeuExcel = CreateObject("Excel.Application")
    MeuExcel.Visible = False
    MeuExcel.Workbooks.Open FileName:=CurrentProject.Path & "\PN.xlsx"
   
    Set RstFrm = Me.RecordsetClone
    RstFrm.Bookmark = Me.RecordsetClone.Bookmark
    MeuExcel.Range("H6") = RstFrm("cliente")
    MeuExcel.Range("H7") = RstFrm("NomeFantasia")
    MeuExcel.Range("H8") = RstFrm("CNPJ")
    MeuExcel.Range("N8") = RstFrm("InscrEstadual")
    MeuExcel.Range("H9") = RstFrm("endereco") & " ," & RstFrm("Numero")
    MeuExcel.Range("N9") = RstFrm("Bairro")
    MeuExcel.Range("H10") = RstFrm("Cidade")
    MeuExcel.Range("N10") = RstFrm("Estado")
    MeuExcel.Range("P10") = RstFrm("CEP")
    MeuExcel.Range("H11") = RstFrm("Fone")
    MeuExcel.Range("N11") = RstFrm("Celular")
    MeuExcel.Range("H12") = RstFrm("EmailNF")
    MeuExcel.Range("H13") = RstFrm("Prazoculta")
    MeuExcel.Range("N12") = RstFrm("ContatoCliente")
    MeuExcel.Range("O5") = RstFrm("DataPed")
    MeuExcel.Range("O15") = RstFrm("VendedorOculta")
    MeuExcel.Range("H15") = RstFrm("Observacao")
    MeuExcel.Range("N14") = RstFrm("DescT")
    MeuExcel.Range("H14") = RstFrm("FOculta")
    MeuExcel.Range("L5") = RstFrm("NossoPedido")

    Set RstSubFrm = Me!SFrmDpedido.Form.RecordsetClone
    RstSubFrm.MoveFirst
    L = 18                  ' Uma celula(celula onde está o texto)antes da inserção.
    Do While Not RstSubFrm.EOF
        L = L + 1
        MeuExcel.Range("A" & L) = RstSubFrm("441")
        MeuExcel.Range("B" & L) = RstSubFrm("462")
        MeuExcel.Range("C" & L) = RstSubFrm("483")
        MeuExcel.Range("D" & L) = RstSubFrm("504")
        MeuExcel.Range("E" & L) = RstSubFrm("526")
        MeuExcel.Range("F" & L) = RstSubFrm("568")
        MeuExcel.Range("G" & L) = RstSubFrm("2GG10")
        MeuExcel.Range("H" & L) = RstSubFrm("3GG12")
        MeuExcel.Range("I" & L) = RstSubFrm("4GG14")
        MeuExcel.Range("J" & L) = RstSubFrm("16")
        MeuExcel.Range("K" & L) = RstSubFrm("18")
        MeuExcel.Range("L" & L) = RstSubFrm("Qtd")

        RstSubFrm.MoveNext
    Loop

    'Fecha o arquivo Excel
    MeuExcel.ActiveWorkbook.Close SaveChanges:=True
    MeuExcel.Visible = True: MeuExcel.Quit: Set MeuExcel = Nothing
    Set RstFrm = Nothing
    Set RstSubFrm = Nothing
    MsgBox "A planilha foi atualizada...", vbInformation, "Aviso"
End Sub

Boa tarde Alexandre....

Show de bola mesmo, fiz com mais de 50 itens no subformulário e foi perfeito.

Agradeço muito a tua ajuda.

Se o Nuno quiser, podemos dar por encerrado o tópico agora.


Abraços a ambos !!

Ok se já resolveste dou então por resolvido.

Boa noite,
Reparei numa instrução desnecessária
Onde está: Dim MeuExcel As Object, Folha
Deve estar: Dim MeuExcel As Object