[Resolvido]Comparar Registros em duas tabelas.

Olá amigos,

Tenho o código abaixo que utilizo no frmConferirLote e preciso fazer um comparativo com os registros selecionados na ListBox com base na (lstXML.Column(0)) , porém, não estou obtendo sucesso, sabendo que estes registro existe na tabela Enviado e Recebido.

'Deixo apenas o registros que preciso comparar o que consta na coluna 0 e 4 da listbox.
Enviado (Me.lstXML.Column(0, i))
Recebido (Me.lstXML.Column(4, i))

E ao executar o código o mesmo está me dizendo que o registro não existe na tabela Recebido, sendo assim, gostaria de uma dica para ajustar o mesmo para que ele faça a leitura correta das tabelas.

Segue exemplo: https://www.dropbox.com/s/pf4s0hbnkiq019n/BD_Teste.rar?dl=0


Dim Arquivo As String
Dim Msg As String
Dim nCount As Integer
'-----------------------------------------------------------------
'Se não fora selecionado registro na lista emite mensagem de aviso
'-----------------------------------------------------------------
If Me.lstXML.ItemsSelected.Count = 0 Then
   '-------------------------------------------------------
   'Emite mensagem de aviso para selecionar ao menos um XML
   '-------------------------------------------------------
   MsgBox "É necessário selecionar ao menos uma conta para iniciar o processo de conferência!", vbCritical, "Erro"
Exit Sub
Else
   '---------------------------------------------
   'Mensagem de questionamento sobre importar
   '---------------------------------------------
   Msg = MsgBox("Deseja conferir o(s) registro(s) selecionado(s)?", vbYesNo + vbQuestion, "Log")
   Select Case Msg
       Case vbYes
           '-----------------------------------
           'Coloca ampulheta no cursor do mouse
           '-----------------------------------
           Screen.MousePointer = 11
           '--------------------------------------------------------------
           'Executa loop pelos registros selecionados para importar o XML
           '--------------------------------------------------------------
           For i = 1 To Me.lstXML.ListCount - 1
               '-------------------------------------------------------------------------------
               'Invoca a função de importação passando como parâmetro o caminho completo
               '-------------------------------------------------------------------------------
               If Me.lstXML.Selected(i) Then
                   Call ConferirTodos(Me.lstXML.Column(1, i))
                   nCount = nCount + 1
               End If
           Next i
       Case vbNo

MsgBox "Foram conferidos " & nCount & " Contas ", vbInformation, "Log"
           Exit Sub
End Select
End If
'------------------------
'Reseta o cursor do mouse
'------------------------
Screen.MousePointer = 0
'----------------------
'DoCmd.Close
'DoCmd.OpenForm "frmConferirLote"
End Sub

Function ConferirTodos(Arquivo As String)

'Dim rsRecebidos     As DAO.Recordset
Dim rsEnviados      As DAO.Recordset
Dim rsComparativo   As DAO.Recordset
Dim StrSQLRec       As String
Dim nCount          As Long
On Error GoTo 10
'-------------------------------------------------------------------------------------------------------------
'Carrego a variável com a SQL da tabela recebidos filtrados pelo campo senhaAutorizaao tendo
'como critério o valor selecionado na cboEnviados. A cboEnviados por sua vez é baseada na tabela Enviados
'Assim o recordset baseado na tabela recebidos conterá apenas os registros cuja guia esteja na tabela enviados
'---------------------------------------------------------------------------------------------------------------
StrSQLRec = "SELECT * FROM Recebido WHERE senhaAutorizacao = Me.lstXML.Column(1)"
'--------------------------------------
'Seto o recordset com a sql da consulta
'--------------------------------------
Set rsRecebidos = CurrentDb.OpenRecordset(StrSQLRec)
'------------------------------------------------------------------
'Movo o ponteiro do recordset para o final em seguida para o início
'------------------------------------------------------------------
rsRecebidos.MoveLast: rsRecebidos.MoveFirst
'-------------------------------------------------------------------------------------
'Caso retorne 1 ou mais registros seta o recordset baseado na tabela comparativo
'executo loop pelo recordset baseado na tabela Recebidos, adicionando um novo registro
'na tabela comparativo. Observe que fiz apenas para dois campo, siga a mesma
'lógica para os demais
'-------------------------------------------------------------------------------------
If rsRecebidos.RecordCount > 0 Then
'
Set rsComparativo = CurrentDb.OpenRecordset("Comparativo")
'
Do While Not rsRecebidos.EOF
'
With rsComparativo
'
.AddNew
'
!NomeUsuário = rsRecebidos!nomeBeneficiario 'Enviado
'
!CódUsuário = rsRecebidos!numeroCarteira 'Enviado
'
!CódGuia = rsRecebidos!senhaAutorizacao 'Enviado
'
!DtAtendimento = rsRecebidos!dataHoraInternacao 'Enviado
'
!DtAlta = DLookup("DtAlta", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!CódServiço = rsRecebidos!codigo 'Enviado
'
!NomeServiço = rsRecebidos!descricao 'Enviado
'
!QtdRecebido = rsRecebidos!quantidade 'Recebido
'
!valorUnitario = rsRecebidos!valorUnitario 'Recebido
'
!valorTotalRecebido = rsRecebidos!valorTotal 'Recebido
'
!Nota = DLookup("Nota", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!Fechamento = DLookup("Fechamento", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!DataCredito = rsRecebidos!DataCredito 'Recebido
'
.Update
'
End With
'----------------------------------------------------------------
'Incremento o contador para exibir mensagem de registros copiados
'----------------------------------------------------------------
nCount = nCount + 1
rsRecebidos.MoveNext
Loop
'------------------------------------
CurrentDb.Execute "INSERT INTO EnviadoConf (NomeUsuário, CódUsuário, CódGuia, DtAtendimento, DtAlta, CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago, Fechamento, Nota)" & vbCrLf & _
"SELECT Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Sum(Enviado.QuantidadeServiço) AS SomaDeQuantidadeServiço, Enviado.Referencia, Sum(Enviado.ValorPago) AS SomaDeValorPago, Enviado.Fechamento, Enviado.Nota" & vbCrLf & _
"FROM Enviado WHERE CódGuia = '" & Me.lstXML & "'" & vbCrLf & _
"GROUP BY Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Enviado.Referencia, Enviado.Fechamento, Enviado.Nota;"
'Deleta os arquivos da tabela Enviado
'------------------------------------
CurrentDb.Execute "DELETE * FROM Enviado WHERE CódGuia = '" & Me.lstXML & "'"
'Deleta os arquivos da tabela Recebido
'------------------------------------
CurrentDb.Execute "DELETE * FROM Recebido WHERE senhaAutorizacao = '" & Me.lstXML & "'"
'---------------------------
Else
10 MsgBox "Nenhum registro encontrado no Demonstrativo de Pagamento!", vbCritical, "Dados Não Encontrados"

End If

End Function

Estou evoluindo com a funcionalidade do código, o mesmo está 95% concluído, falta somente o detalhe que relato abaixo:

No formulario (frmConferirLote), possui uma listbox com o nome (lstXML), a lista tem propriedade Seleções múltiplas definida como Estendida.

Porém, se eu selecionar dois registros na lista ele compara somente um e ignora o outro.

Alguém tem uma dica para complementar, pois gostaria que ao selecionar dois ou mais ele compare o que foi selecionado?

Hoje independente da quantidade que eu seleciono o código compara somente um registro.

Private Sub btnImportar_Click()
Dim Arquivo As String
Dim Msg As String
Dim nCount As Integer
'-----------------------------------------------------------------
'Se não fora selecionado registro na lista emite mensagem de aviso
'-----------------------------------------------------------------
If Me.lstXML.ItemsSelected.Count = 0 Then
   '-------------------------------------------------------
   'Emite mensagem de aviso para selecionar ao menos um XML
   '-------------------------------------------------------
   MsgBox "É necessário selecionar ao menos uma conta para iniciar o processo de conferência!", vbCritical, "Erro"
Exit Sub
Else
   '---------------------------------------------
   'Mensagem de questionamento sobre importar
   '---------------------------------------------
   Msg = MsgBox("Deseja conferir o(s) registro(s) selecionado(s)?", vbYesNo + vbQuestion, "Log")
   Select Case Msg
       Case vbYes
           '-----------------------------------
           'Coloca ampulheta no cursor do mouse
           '-----------------------------------
           Screen.MousePointer = 11
           '--------------------------------------------------------------
           'Executa loop pelos registros selecionados para conferir
           '--------------------------------------------------------------
           For i = 1 To Me.lstXML.ListCount + 1
               '-------------------------------------------------------------------------------
               'Invoca a função de importação passando como parâmetro o caminho completo
               '-------------------------------------------------------------------------------
               If Me.lstXML.Selected(i) Then
                   Call ConferirTodos(Me.lstXML.Column(0, i))
                   nCount = nCount + 1
               End If
           Next i
       Case vbNo

           Exit Sub
End Select
End If
'------------------------
'Reseta o cursor do mouse
'------------------------
Screen.MousePointer = 0
'----------------------
MsgBox "Foram conferidos " & nCount & " Contas ", vbInformation, "Log"
Me.Recalc
'DoCmd.Close
'DoCmd.OpenForm "frmConferirLote"
End Sub

Function ConferirTodos(Arquivo As String)

Dim rsRecebidos     As DAO.Recordset
Dim rsEnviados      As DAO.Recordset
Dim rsComparativo   As DAO.Recordset
Dim StrSQLRec       As String
Dim nCount          As Long
On Error GoTo 10
'-------------------------------------------------------------------------------------------------------------
'Carrego a variável com a SQL da tabela recebidos filtrados pelo campo senhaAutorizaao tendo
'como critério o valor selecionado na cboEnviados. A cboEnviados por sua vez é baseada na tabela Enviados
'Assim o recordset baseado na tabela recebidos conterá apenas os registros cuja guia esteja na tabela enviados
'---------------------------------------------------------------------------------------------------------------
StrSQLRec = "SELECT * FROM Recebido WHERE senhaAutorizacao = '" & Me.lstXML.Column(4) & "'"
'--------------------------------------
'Seto o recordset com a sql da consulta
'--------------------------------------
Set rsRecebidos = CurrentDb.OpenRecordset(StrSQLRec)
'------------------------------------------------------------------
'Movo o ponteiro do recordset para o final em seguida para o início
'------------------------------------------------------------------
rsRecebidos.MoveLast: rsRecebidos.MoveFirst
'-------------------------------------------------------------------------------------
'Caso retorne 1 ou mais registros seta o recordset baseado na tabela comparativo
'executo loop pelo recordset baseado na tabela Recebidos, adicionando um novo registro
'na tabela comparativo. Observe que fiz apenas para dois campo, siga a mesma
'lógica para os demais
'-------------------------------------------------------------------------------------
If rsRecebidos.RecordCount > 0 Then
'
Set rsComparativo = CurrentDb.OpenRecordset("Comparativo")
'
Do While Not rsRecebidos.EOF
'
With rsComparativo
'
.AddNew
'
!NomeUsuário = rsRecebidos!nomeBeneficiario 'Enviado
'
!CódUsuário = rsRecebidos!numeroCarteira 'Enviado
'
!CódGuia = rsRecebidos!senhaAutorizacao 'Enviado
'
!DtAtendimento = rsRecebidos!dataHoraInternacao 'Enviado
'
!DtAlta = DLookup("DtAlta", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!CódServiço = rsRecebidos!codigo 'Enviado
'
!NomeServiço = rsRecebidos!descricao 'Enviado
'
!QtdRecebido = rsRecebidos!quantidade 'Recebido
'
!valorUnitario = rsRecebidos!valorUnitario 'Recebido
'
!valorTotalRecebido = rsRecebidos!valorTotal 'Recebido
'
!Nota = DLookup("Nota", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!Fechamento = DLookup("Fechamento", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!DataCredito = rsRecebidos!DataCredito 'Recebido
'
.Update
'
End With
'----------------------------------------------------------------
'Incremento o contador para exibir mensagem de registros copiados
'----------------------------------------------------------------
nCount = nCount + 1
rsRecebidos.MoveNext
Loop
'------------------------------------
CurrentDb.Execute "INSERT INTO EnviadoConf (NomeUsuário, CódUsuário, CódGuia, DtAtendimento, DtAlta, CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago, Fechamento, Nota)" & vbCrLf & _
"SELECT Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Sum(Enviado.QuantidadeServiço) AS SomaDeQuantidadeServiço, Enviado.Referencia, Sum(Enviado.ValorPago) AS SomaDeValorPago, Enviado.Fechamento, Enviado.Nota" & vbCrLf & _
"FROM Enviado WHERE CódGuia = '" & Me.lstXML.Column(0) & "'" & vbCrLf & _
"GROUP BY Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Enviado.Referencia, Enviado.Fechamento, Enviado.Nota;"
'Deleta os arquivos da tabela Enviado
'------------------------------------
CurrentDb.Execute "DELETE * FROM Enviado WHERE CódGuia =  '" & Me.lstXML.Column(0) & "'"
'Deleta os arquivos da tabela Recebido
'------------------------------------
CurrentDb.Execute "DELETE * FROM Recebido WHERE senhaAutorizacao =  '" & Me.lstXML.Column(4) & "'"
'---------------------------
Else
10 MsgBox "Nenhum registro encontrado no Demonstrativo de Pagamento!", vbCritical, "Dados Não Encontrados"

End If

End Function

Olá
Acho que este exemplo poderá iluminar as ideias veja.

https://www.maximoaccess.com/t23167-selecionar-em-listbox

boa sorte.

Obrigado amigo,

Fiz o download e vou estudar o código para ajuste do meu sistema.

Falta só um detalhe para resolver a questão, mas ainda não consegui vislumbrar.

Deu uma olhada no exemplo mas não clareou nada.

Inserir uma combo no meu exemplo para filtrar os dados (após atualizar) e o código que faz a comparação funcionou direitinho, já nos testes dos registros que seleciono com base na listbox o código somente confere um registro. Ou seja, se eu seleciono 3 o código deveria comparar o que selecionei na listbox.

Alguém tem outra ideia para sugerir?

Segue código do exemplo já postado.

Private Sub btnImportar_Click()
Dim Arquivo As String
Dim Msg As String
Dim nCount As Integer
'-----------------------------------------------------------------
'Se não fora selecionado registro na lista emite mensagem de aviso
'-----------------------------------------------------------------
If Me.lstXML.ItemsSelected.Count = 0 Then
'-------------------------------------------------------
'Emite mensagem de aviso para selecionar ao menos um XML
'-------------------------------------------------------
MsgBox "É necessário selecionar ao menos uma conta para iniciar o processo de conferência!", vbCritical, "Erro"
Exit Sub
Else
'---------------------------------------------
'Mensagem de questionamento sobre importar
'---------------------------------------------
Msg = MsgBox("Deseja conferir o(s) registro(s) selecionado(s)?", vbYesNo + vbQuestion, "Log")
Select Case Msg
Case vbYes
'-----------------------------------
'Coloca ampulheta no cursor do mouse
'-----------------------------------
Screen.MousePointer = 11
'--------------------------------------------------------------
'Executa loop pelos registros selecionados para conferir
'--------------------------------------------------------------
For i = 1 To Me.lstXML.ListCount + 1
'-------------------------------------------------------------------------------
'Invoca a função de importação passando como parâmetro o caminho completo
'-------------------------------------------------------------------------------
If Me.lstXML.Selected(i) Then
Call ConferirTodos(Me.lstXML.Column(0, i))
nCount = nCount + 1
End If
Next i
Case vbNo

Exit Sub
End Select
End If
'------------------------
'Reseta o cursor do mouse
'------------------------
Screen.MousePointer = 0
'----------------------
MsgBox "Foram conferidos " & nCount & " Contas ", vbInformation, "Log"
Me.Recalc
'DoCmd.Close
'DoCmd.OpenForm "frmConferirLote"
End Sub

Function ConferirTodos(Arquivo As String)

Dim rsRecebidos As DAO.Recordset
Dim rsEnviados As DAO.Recordset
Dim rsComparativo As DAO.Recordset
Dim StrSQLRec As String
Dim nCount As Long
On Error GoTo 10
'-------------------------------------------------------------------------------------------------------------
'Carrego a variável com a SQL da tabela recebidos filtrados pelo campo senhaAutorizaao tendo
'como critério o valor selecionado na cboEnviados. A cboEnviados por sua vez é baseada na tabela Enviados
'Assim o recordset baseado na tabela recebidos conterá apenas os registros cuja guia esteja na tabela enviados
'---------------------------------------------------------------------------------------------------------------
StrSQLRec = "SELECT * FROM Recebido WHERE senhaAutorizacao = '" & Me.lstXML.Column(4) & "'"
'--------------------------------------
'Seto o recordset com a sql da consulta
'--------------------------------------
Set rsRecebidos = CurrentDb.OpenRecordset(StrSQLRec)
'------------------------------------------------------------------
'Movo o ponteiro do recordset para o final em seguida para o início
'------------------------------------------------------------------
rsRecebidos.MoveLast: rsRecebidos.MoveFirst
'-------------------------------------------------------------------------------------
'Caso retorne 1 ou mais registros seta o recordset baseado na tabela comparativo
'executo loop pelo recordset baseado na tabela Recebidos, adicionando um novo registro
'na tabela comparativo. Observe que fiz apenas para dois campo, siga a mesma
'lógica para os demais
'-------------------------------------------------------------------------------------
If rsRecebidos.RecordCount > 0 Then
'
Set rsComparativo = CurrentDb.OpenRecordset("Comparativo")
'
Do While Not rsRecebidos.EOF
'
With rsComparativo
'
.AddNew
'
!NomeUsuário = rsRecebidos!nomeBeneficiario 'Enviado
'
!CódUsuário = rsRecebidos!numeroCarteira 'Enviado
'
!CódGuia = rsRecebidos!senhaAutorizacao 'Enviado
'
!DtAtendimento = rsRecebidos!dataHoraInternacao 'Enviado
'
!DtAlta = DLookup("DtAlta", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!CódServiço = rsRecebidos!codigo 'Enviado
'
!NomeServiço = rsRecebidos!descricao 'Enviado
'
!QtdRecebido = rsRecebidos!quantidade 'Recebido
'
!valorUnitario = rsRecebidos!valorUnitario 'Recebido
'
!valorTotalRecebido = rsRecebidos!valorTotal 'Recebido
'
!Nota = DLookup("Nota", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!Fechamento = DLookup("Fechamento", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!DataCredito = rsRecebidos!DataCredito 'Recebido
'
.Update
'
End With
'----------------------------------------------------------------
'Incremento o contador para exibir mensagem de registros copiados
'----------------------------------------------------------------
nCount = nCount + 1
rsRecebidos.MoveNext
Loop
'------------------------------------
CurrentDb.Execute "INSERT INTO EnviadoConf (NomeUsuário, CódUsuário, CódGuia, DtAtendimento, DtAlta, CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago, Fechamento, Nota)" & vbCrLf & _
"SELECT Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Sum(Enviado.QuantidadeServiço) AS SomaDeQuantidadeServiço, Enviado.Referencia, Sum(Enviado.ValorPago) AS SomaDeValorPago, Enviado.Fechamento, Enviado.Nota" & vbCrLf & _
"FROM Enviado WHERE CódGuia = '" & Me.lstXML.Column(0) & "'" & vbCrLf & _
"GROUP BY Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Enviado.Referencia, Enviado.Fechamento, Enviado.Nota;"
'Deleta os arquivos da tabela Enviado
'------------------------------------
CurrentDb.Execute "DELETE * FROM Enviado WHERE CódGuia = '" & Me.lstXML.Column(0) & "'"
'Deleta os arquivos da tabela Recebido
'------------------------------------
CurrentDb.Execute "DELETE * FROM Recebido WHERE senhaAutorizacao = '" & Me.lstXML.Column(4) & "'"
'---------------------------
Else
10 MsgBox "Nenhum registro encontrado no Demonstrativo de Pagamento!", vbCritical, "Dados Não Encontrados"

End If

End Function

Up.

Up.

Up.

Up.

Up.

Para poder ler os indexes selecionados na lista, não deverá ter uma função separada, faça sempre o simples;

Teste e retorne por favor;

Código:

Private Sub btnImportar_Click()
Dim Arquivo As String
Dim Msg As String
Dim nCount As Integer
Dim rsRecebidos As DAO.Recordset
Dim rsEnviados As DAO.Recordset
Dim rsComparativo As DAO.Recordset
Dim StrSQLRec As String
Dim i As Variant

On Error GoTo 10
'-----------------------------------------------------------------
'Se não fora selecionado registro na lista emite mensagem de aviso
'-----------------------------------------------------------------
If Me.lstXML.ItemsSelected.Count = 0 Then
'-------------------------------------------------------
'Emite mensagem de aviso para selecionar ao menos um XML
'-------------------------------------------------------
MsgBox "É necessário selecionar ao menos uma conta para iniciar o processo de conferência!", vbCritical, "Erro"
Exit Sub
Else
'---------------------------------------------
'Mensagem de questionamento sobre importar
'---------------------------------------------
Msg = MsgBox("Deseja conferir o(s) registro(s) selecionado(s)?", vbYesNo + vbQuestion, "Log")
Select Case Msg
Case vbYes
'-----------------------------------
'Coloca ampulheta no cursor do mouse
'-----------------------------------
Screen.MousePointer = 11
'--------------------------------------------------------------
'Executa loop pelos registros selecionados para conferir

For i = 0 To Me.lstXML.ListCount - 1
    If Me.lstXML.Selected(i) = True Then
'-------------------------------------------------------------------------------------------------------------
'Carrego a variável com a SQL da tabela recebidos filtrados pelo campo senhaAutorizaao tendo
'como critério o valor selecionado na cboEnviados. A cboEnviados por sua vez é baseada na tabela Enviados
'Assim o recordset baseado na tabela recebidos conterá apenas os registros cuja guia esteja na tabela enviados
'---------------------------------------------------------------------------------------------------------------
StrSQLRec = "SELECT * FROM Recebido WHERE senhaAutorizacao = '" & Me.lstXML.Column(4, i) & "'"
'--------------------------------------
'Seto o recordset com a sql da consulta
'--------------------------------------
Set rsRecebidos = CurrentDb.OpenRecordset(StrSQLRec)
'------------------------------------------------------------------
'Movo o ponteiro do recordset para o final em seguida para o início
'------------------------------------------------------------------
rsRecebidos.MoveLast: rsRecebidos.MoveFirst
'-------------------------------------------------------------------------------------
'Caso retorne 1 ou mais registros seta o recordset baseado na tabela comparativo
'executo loop pelo recordset baseado na tabela Recebidos, adicionando um novo registro
'na tabela comparativo. Observe que fiz apenas para dois campo, siga a mesma
'lógica para os demais
'-------------------------------------------------------------------------------------
If rsRecebidos.RecordCount > 0 Then
'
Set rsComparativo = CurrentDb.OpenRecordset("SELECT * FROM Comparativo")
'
Do While Not rsRecebidos.EOF
'
With rsComparativo
'
.AddNew
'
!NomeUsuário = rsRecebidos!nomeBeneficiario 'Enviado
'
!CódUsuário = rsRecebidos!numeroCarteira 'Enviado
'
!CódGuia = rsRecebidos!senhaAutorizacao 'Enviado
'
!DtAtendimento = rsRecebidos!dataHoraInternacao 'Enviado
'
!DtAlta = DLookup("DtAlta", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!CódServiço = rsRecebidos!codigo 'Enviado
'
!NomeServiço = rsRecebidos!descricao 'Enviado
'
!QtdRecebido = rsRecebidos!quantidade 'Recebido
'
!valorUnitario = rsRecebidos!valorUnitario 'Recebido
'
!valorTotalRecebido = rsRecebidos!valorTotal 'Recebido
'
!Nota = DLookup("Nota", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!Fechamento = DLookup("Fechamento", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!DataCredito = rsRecebidos!DataCredito 'Recebido
'
.Update
'
End With

CurrentDb.Execute "INSERT INTO EnviadoConf (NomeUsuário, CódUsuário, CódGuia, DtAtendimento, DtAlta, CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago, Fechamento, Nota)" & vbCrLf & _
"SELECT Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Sum(Enviado.QuantidadeServiço) AS SomaDeQuantidadeServiço, Enviado.Referencia, Sum(Enviado.ValorPago) AS SomaDeValorPago, Enviado.Fechamento, Enviado.Nota" & vbCrLf & _
"FROM Enviado WHERE CódGuia = '" & Me.lstXML.Column(0, i) & "'" & vbCrLf & _
"GROUP BY Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Enviado.Referencia, Enviado.Fechamento, Enviado.Nota;"

'------------------------------------
'Deleta os arquivos da tabela Enviado
'------------------------------------
CurrentDb.Execute "DELETE * FROM Enviado WHERE CódGuia = '" & Me.lstXML.Column(0, i) & "'"
'Deleta os arquivos da tabela Recebido
'------------------------------------
CurrentDb.Execute "DELETE * FROM Recebido WHERE senhaAutorizacao = '" & Me.lstXML.Column(4, i) & "'"

'---------------------------
'----------------------------------------------------------------
'Incremento o contador para exibir mensagem de registros copiados
'----------------------------------------------------------------
nCount = nCount + 1
rsRecebidos.MoveNext

Loop

Else
10 MsgBox "Nenhum registro encontrado no Demonstrativo de Pagamento!", vbCritical, "Dados Não Encontrados"

End If

    End If
Next i

Case vbNo

Exit Sub
End Select
End If
'------------------------
'Reseta o cursor do mouse
'------------------------
Screen.MousePointer = 0
'----------------------
MsgBox "Foram conferidos " & nCount & " Contas ", vbInformation, "Log"
Me.Recalc

End Sub

Obrigado mestre JPaulo,

Farei os devidos testes e darei breve retorno.

Prezado,

Fiz os testes do código e ele está faltando um detalhe para concluir, segue:

Na listbox eu seleciono dados cuja origem da linha é:
SELECT Enviado.CódGuia, Enviado.NomeUsuário, Enviado.DtAtendimento, Enviado.ValorPago, Recebido.senhaAutorizacao, Recebido.nomeBeneficiario, Recebido.dataHoraInternacao, Sum(Recebido.valorTotal) AS [Total Recebido] FROM Enviado INNER JOIN Recebido ON Enviado.CódGuia=Recebido.senhaAutorizacao GROUP BY Enviado.CódGuia, Enviado.NomeUsuário, Enviado.DtAtendimento, Enviado.ValorPago, Recebido.senhaAutorizacao, Recebido.nomeBeneficiario, Recebido.dataHoraInternacao;

suponhamos que eu seleciona na listbox o dado abaixo e executo o código:
1º Na tabela enviado tenho estes registros:
Paciente Matricula Senha Internação Código Descrição Qtd Total Recebido
aaaaaaaaaaaaaaaaaaaa 0000000000700 1143694799 25/08/2014 10101039 CONSULTA 1 R$ 138,62

2º Já na tabela recebido tenho estes registros correspondente, observe que está em duas linhas:
Paciente Matricula Senha Internação Código Descrição Qtd Total Recebido
aaaaaaaaaaaaaaaaaaaa 0000000000700 1143694799 25/08/2014 10101039 CONSULTA 1 R$ 55,00
aaaaaaaaaaaaaaaaaaaa 0000000000700 1143694799 25/08/2014 60033720 TAXA DE SALA R$ 83,62

Quando o código faz a comparação, ele manda para tabela Comparativo dois registros, o que está devidamente correto.

Quando o código faz a comparação, ele manda para tabela com INSERT INTO EnviadoConf também dois registros, mas o correto seria enviar apenas o que está citado no primeiro tópico em azul.

Agradeço novas dicas.

Dim Arquivo As String
Dim Msg As String
Dim nCount As Integer
Dim rsRecebidos As DAO.Recordset
Dim rsEnviados As DAO.Recordset
Dim rsComparativo As DAO.Recordset
Dim StrSQLRec As String
Dim i As Variant

On Error GoTo 10
'-----------------------------------------------------------------
'Se não fora selecionado registro na lista emite mensagem de aviso
'-----------------------------------------------------------------
If Me.lstXML.ItemsSelected.Count = 0 Then
'-------------------------------------------------------
'Emite mensagem de aviso para selecionar ao menos um XML
'-------------------------------------------------------
MsgBox "É necessário selecionar ao menos uma conta para iniciar o processo de conferência!", vbCritical, "Erro"
Exit Sub
Else
'---------------------------------------------
'Mensagem de questionamento sobre importar
'---------------------------------------------
Msg = MsgBox("Deseja conferir o(s) registro(s) selecionado(s)?", vbYesNo + vbQuestion, "Log")
Select Case Msg
Case vbYes
'-----------------------------------
'Coloca ampulheta no cursor do mouse
'-----------------------------------
Screen.MousePointer = 11
'--------------------------------------------------------------
'Executa loop pelos registros selecionados para conferir

For i = 0 To Me.lstXML.ListCount - 1
If Me.lstXML.Selected(i) = True Then
'-------------------------------------------------------------------------------------------------------------
'Carrego a variável com a SQL da tabela recebidos filtrados pelo campo senhaAutorizaao tendo
'como critério o valor selecionado na cboEnviados. A cboEnviados por sua vez é baseada na tabela Enviados
'Assim o recordset baseado na tabela recebidos conterá apenas os registros cuja guia esteja na tabela enviados
'---------------------------------------------------------------------------------------------------------------
StrSQLRec = "SELECT * FROM Recebido WHERE senhaAutorizacao = '" & Me.lstXML.Column(4, i) & "'"
'--------------------------------------
'Seto o recordset com a sql da consulta
'--------------------------------------
Set rsRecebidos = CurrentDb.OpenRecordset(StrSQLRec)
'------------------------------------------------------------------
'Movo o ponteiro do recordset para o final em seguida para o início
'------------------------------------------------------------------
rsRecebidos.MoveLast: rsRecebidos.MoveFirst
'-------------------------------------------------------------------------------------
'Caso retorne 1 ou mais registros seta o recordset baseado na tabela comparativo
'executo loop pelo recordset baseado na tabela Recebidos, adicionando um novo registro
'na tabela comparativo. Observe que fiz apenas para dois campo, siga a mesma
'lógica para os demais
'-------------------------------------------------------------------------------------
If rsRecebidos.RecordCount > 0 Then
'
Set rsComparativo = CurrentDb.OpenRecordset("SELECT * FROM Comparativo")
'
Do While Not rsRecebidos.EOF
'
With rsComparativo
'
.AddNew
'
!NomeUsuário = rsRecebidos!nomeBeneficiario 'Enviado
'
!CódUsuário = rsRecebidos!numeroCarteira 'Enviado
'
!CódGuia = rsRecebidos!senhaAutorizacao 'Enviado
'
!DtAtendimento = rsRecebidos!dataHoraInternacao 'Enviado
'
!DtAlta = DLookup("DtAlta", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!CódServiço = rsRecebidos!codigo 'Enviado
'
!NomeServiço = rsRecebidos!descricao 'Enviado
'
!QtdRecebido = rsRecebidos!quantidade 'Recebido
'
!valorUnitario = rsRecebidos!valorUnitario 'Recebido
'
!valorTotalRecebido = rsRecebidos!valorTotal 'Recebido
'
!Nota = DLookup("Nota", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!Fechamento = DLookup("Fechamento", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'") 'Enviado
'
!DataCredito = rsRecebidos!DataCredito 'Recebido
'
.Update
'

End With

CurrentDb.Execute "INSERT INTO EnviadoConf (NomeUsuário, CódUsuário, CódGuia, DtAtendimento, DtAlta, CódServiço, NomeServiço, QuantidadeServiço, Referencia, ValorPago, Fechamento, Nota)" & vbCrLf & _
"SELECT Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Sum(Enviado.QuantidadeServiço) AS SomaDeQuantidadeServiço, Enviado.Referencia, Sum(Enviado.ValorPago) AS SomaDeValorPago, Enviado.Fechamento, Enviado.Nota" & vbCrLf & _
"FROM Enviado WHERE CódGuia = '" & Me.lstXML.Column(4, i) & "'" & vbCrLf & _
"GROUP BY Enviado.NomeUsuário, Enviado.CódUsuário, Enviado.CódGuia, Enviado.DtAtendimento, Enviado.DtAlta, Enviado.CódServiço, Enviado.NomeServiço, Enviado.Referencia, Enviado.Fechamento, Enviado.Nota;"

'------------------------------------
'Deleta os arquivos da tabela Enviado
'------------------------------------
'CurrentDb.Execute "DELETE * FROM Enviado WHERE CódGuia = '" & Me.lstXML.Column(0, i) & "'"
'Deleta os arquivos da tabela Recebido
'------------------------------------
'CurrentDb.Execute "DELETE * FROM Recebido WHERE senhaAutorizacao = '" & Me.lstXML.Column(4, i) & "'"

'---------------------------
'----------------------------------------------------------------
'Incremento o contador para exibir mensagem de registros copiados
'----------------------------------------------------------------
nCount = nCount + 1
rsRecebidos.MoveNext

Loop

Else
10 MsgBox "Nenhum registro encontrado no Demonstrativo de Pagamento!", vbCritical, "Dados Não Encontrados"

End If

End If
Next i

Case vbNo

Exit Sub
End Select
End If
'------------------------
'Reseta o cursor do mouse
'------------------------
Screen.MousePointer = 0
'----------------------
MsgBox "Foram conferidos " & nCount / 2 & " Contas ", vbInformation, "Log"
Me.Recalc
Me.Requery

Up.

Dando continuidade a dúvida que tenho.
O código ainda não importa 100% das informações, ou seja, se o registro tem duas linhas, a primeira é importada completamente, a segundo está importtando e deletando dados.

Dados inseridos por meio de Dlookup, como segue:

!Nota = DLookup("Nota", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'")
!Fechamento = DLookup("Fechamento", "Enviado", "CódGuia = '" & rsRecebidos!senhaAutorizacao & "'")

Up.

Up.

Up.

Up.

Up.

Ok Dilson,

Vou alterar e retorno.

Att,

Caro Dilson,

Fiz alguns testes locais e funcionou perfeitamente amigo.
Agora vou rodar em rede e ver o funcionamento na prática.

Muito obrigado.