[Resolvido]Duplicação de Registros - Formulário/Subformulários

Bom dia!

Estou com dificuldades para realizar a duplicação de registros. Já pesquisei aqui no fórum as diversas soluções disponibilizadas, porém, não consegui ajustar nenhuma para solucionar o meu problema.

Assim, peço ajuda a todos para colaborar na solução da minha demanda, a qual acredito poderá ser de várias pessoas.

Vamos lá!  

Tenho uma tabela denominada tblMovFinanceira e outra tblObsMovFinanceira. Na primeira constam diversos campos para registrar as movimentações financeiras e na segunda consta um campo para registro de observações a respeito de alguma movimentação específica.

Como existem movimentações financeiras que irão se repetir durante todo o ano, inclusive com as respectivas observações, a duplicação desses registros ajudariam, em muito, o trabalho do operador.

Conforme o código abaixo, que extrair da colaboração de outros colegas, consigo duplicar os registros da tblMovFinanceira com tranquilidade. O problema é quando estes possuem também registros vinculados na tblObsMovFinanceira. No caso não consigo duplicar os registros desta tabela (tblObsMovFinanceira), pois não consigo fazer com que o novo registro pegue o novo ID do registro duplicado para ser utilizado como Chave Estrangeira no novo registro da tblObsMovFinanceira.

Dessa forma, colo o código atualmente utilizado, bem como, anexo um BD de teste que preparei para facilitar a ajuda do Fórum!

Lembrando, com esse código só consegui duplicar o registro da tblMovFinanceira, ficando pendente a duplicação do registro vinculado na tblObsMovFinanceira.


Private Sub cmdDuplicar_Click()

Dim bd As DAO.Database
Dim rs As DAO.Recordset
Dim Duplicar As Integer
Dim i As Integer


If IsNull(Me.txtDuplicar) Then

   MsgBox "Atenção! Preencha a quantidade de registros a serem duplicados.", , "Atenção!"
   Exit Sub

End If

   Set bd = CurrentDb
   Set rs = bd.OpenRecordset("tblFaturamento")
   
   Duplicar = txtDuplicar

   For i = 1 To Duplicar
   
   rs.AddNew
   rs.Fields("DataMov") = Me!DataMov
   rs.Fields("Fornecedor") = Me!Fornecedor
   rs.Update
   Next i

   rs.Close
   bd.Close
     
   Set rs = Nothing
   Set bd = Nothing
     
   
   MsgBox "Registros replicados!", vbInformation, "Replicação!"

End Sub

Cade o anexo.

Anexei!

Eu não sei o que acontece que não consigo postar mais nenhum anexo no fórum

""Os seguintes erros foram encontrados
Não foi possível enviar o arquivo : o espaço de armazenamento para usuários foi ultrapassado. (Espaço restante : 18 Kb)""


Substitua o seu código por este



'Scandinavo 02/07/21
'Faz a copia de registros do formulario e subformulario

Dim bd As dao.Database
Dim rs As dao.Recordset 'tblFaturamento
Dim rsOF As dao.Recordset 'tblObsFaturamento
Dim rst As dao.Recordset 'subfrmulario
Dim Duplicar As Integer
Dim i As Integer


If IsNull(Me.txtDuplicar) Then

MsgBox "Aten??o! Preencha a quantidade de registros a serem duplicados.", , "Aten??o!"
Exit Sub

End If

Set bd = CurrentDb()
Set rs = bd.OpenRecordset("tblFaturamento")

Duplicar = txtDuplicar
For i = 1 To Duplicar
'primeiro cria o novo Idfat na tblFaturamento
rs.AddNew
rs.Fields("DataMov") = Me!DataMov
rs.Fields("Fornecedor") = Me!Fornecedor
rs.Update

DoCmd.RunCommand acCmdSaveRecord 'Salvo o Registro
'abre a tabela para inserir os registros copiados
Set rsOF = bd.OpenRecordset("tblObsFaturamento")
'fazendo referencia ao subformulario
Set rst = Me.frmSubFaturamento.Form.Recordset
rst.MoveFirst 'Vai percorrer todo o subformulario
Do While Not rst.EOF ' ate o fim
With rst
rsOF.AddNew
rsOF!IdFat = DLast("IdFat", "tblFaturamento") 'Busca o ultimo idFat para fazer a vincula??o entre os registros
'estes s?o campos que voce quer copiar
rsOF!Obs = rst!Obs
rsOF.Update
.MoveNext
End With
Loop

Next i

MsgBox "Registros replicados!", vbInformation, "Replica??o!"

Set rs = Nothing
Set rst = Nothing
Set rsOF = Nothing

Scandinavo, boa noite!

Show de bola! Obrigado pela sua disponibilidade e tempo em contribuir com minha dúvida e, acredito, de diversos seguidores do Fórum.

O código atendeu ao meu objetivo. Porém, ocorre um pequeno erro quando não existe dados a serem copiados do Subformulário/Tabela (tblObsFaturamento).

De forma a superá-lo utilizei um "On Error Resume Next", o que permite a continuidade da execução do código sem prejuízo ao objetivo final.

Aproveito para anexar o exemplo com o respectivo código.

Valeu!!!

Valeu pelo retorno

Faltou marcar o post como resolvido.

Resolvido!!