[Resolvido]Transferir registro para outra tabela

Olá, Mestres! Estou com dificuldades de adaptar o código postado pelo Mestre Avelino Sampaio em outro tópico, para transferir um registro da tabela principal para outra e ao mesmo tempo deletando esse registro da tabela principal.

Segue o código adaptado (só consigo transferir apenas 1 registro e quando vou transferir outro, o access trava:


Public Sub tabExonerar(cod As Long)
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim strSQL As String
strSQL = "SELECT * FROM Tabela1 WHERE codigo=" & cod
Set rs = CurrentDb.OpenRecordset(strSQL)
Set rs2 = CurrentDb.OpenRecordset("Lista_de_Exonerados")
Do While Not rs.EOF
   
   rs2.AddNew
       
       rs2!Matrícula = rs!Matrícula
       rs2!Nome = rs!Nome
       rs2!Cargo = rs!Cargo
       rs2!Função = rs!Função
       rs2!Símbolo = rs!Símbolo
       rs2!Lotação = rs!Lotação
       Do While Not rs2.EOF
     
       
   Loop
   rs2.Update
   rs.MoveNext
Loop
rs2.Close
rs.Close
Set rs2 = Nothing
Set rs = Nothing
CurrentDb.Execute "Delete * from Tabela1 where codigo=" & cod
MsgBox "Dados transferidos para a tabela Exonerados.  Abra a tabela e verifique....", vbInformation, "Aviso"
End Sub

Boas.....

Qual o nome do dito formulário envolvido na questão ?

Saudações, Silvio!


Gostaria de transferir os registros da Tabela1 para tabela Lista_de_Exonerados ao clicar no botão pelo formulário frm_Exonerados, assim excluindo o registro da tabela1 que foi transferido.

Bem....do jeito que está aparecendo os dados no teu formulário você está exportando um a um.

De uma revisada nisso.

Abaixo um código para você adaptar em teu projeto.

Código:

        'Declaração das Variaveis
Dim DB As Database
Dim rs As DAO.Recordset ' TblPrepostoTmp - onde estão os dados que serão importados
Dim rs1 As DAO.Recordset ' tblacertocomissao -  para onde irão os dados a serem importados.


Set DB = CurrentDb()


                'Filtra os dados da tabela de Origem e Define a tabela de Destino dos dados.
    Set rs = DB.OpenRecordset("SELECT * FROM TblPrepostoTmp ")  ' tabela de origem(RS)
    Set rs1 = DB.OpenRecordset("tblacertocomissao") ' tabela de destino (RS1)

 
'Inicia a Gravação dos dados na Tabela de Destino Selecionada Nas condiçoes a cima
'Repete até COPIAR todos os Registros que foram selecionados
Do While Not rs.EOF
        'Inicia a Gravação dos dados na tblacertocomissao (RS1)
        rs1.AddNew
        rs1("CodPed") = rs("CodPed")
        rs1("DataPed") = rs("DataPed")
        rs1("NossoPedido") = rs("NossoPedido") & " / " & rs("VendedorOculta")
        rs1("VendedorOculta") = rs("VendedorOculta")
        rs1("Cliente") = rs("Cliente")
        rs1("PrazoOculta") = rs("PrazoOculta")
        rs1("ValortotalPedido") = rs("ValortotalPedido")
        rs1("ForneOculta") = rs("ForneOculta")
        rs1("Efetivado") = rs("Efetivado")
        rs1.Update
    rs.MoveNext
    Loop


    'Ao Final Encerra as Conexões
    rs.Close
    rs1.Close
    DB.Close

   


       
        MsgBox "Operação concluída.", vbInformation, Me.Caption
       
        'apaga temporarios da tblprepostotmp que recebeu a importação.
        DoCmd.RunSQL "Delete * from TblPrepostoTmp"

Bons estudos.

Boa noite, Silvio!

Primeiramente obrigado pela a sua atenção e ajuda...

Eu estudei o seu código, entendi e assim deletei algumas linhas do código em que eu estava usando e só felicidades, muito obrigado Silvio \o/

Segue o código modificado:

Public Sub tabExonerar(cod As Long)
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim strSQL As String
strSQL = "SELECT * FROM Tabela1 WHERE codigo=" & cod
Set rs = CurrentDb.OpenRecordset(strSQL)
Set rs2 = CurrentDb.OpenRecordset("Lista_de_Exonerados")
Do While Not rs.EOF

rs2.AddNew

rs2!Matrícula = rs!Matrícula
rs2!Nome = rs!Nome
rs2!Cargo = rs!Cargo
rs2!Função = rs!Função
rs2!Símbolo = rs!Símbolo
rs2!Lotação = rs!Lotação




rs2.Update
rs.MoveNext
Loop
rs2.Close
rs.Close
Set rs2 = Nothing
Set rs = Nothing
CurrentDb.Execute "Delete * from Tabela1 where codigo=" & cod
MsgBox "Dados transferidos para a tabela Exonerados. Abra a tabela e verifique....", vbInformation, "Aviso"
End Sub

Bom dia.

Fico feliz em ter lhe ajudado.

Abraços.