MaximoAccess

Caro Usuário, não tire as suas duvidas nas Salas de Repositório, abra sempre um novo tópico relacionado, nas salas destinadas para o efeito, como Sala de Tabelas, Consultas, Formulários, Relatórios, Macros, Módulos e VBA.

Obrigado

Administração do MaximoAccess

Dicas Ms Access, Exemplos Ms Access, Codigos VBA Ms Access, SQL Ms Access

    [Resolvido]Comparar Registros em duas tabelas.

    Compartilhe

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Sab 22 Ago 2015, 23:23

    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: [Você precisa estar registrado e conectado para ver este link.]


    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

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Dom 23 Ago 2015, 22:55

    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

    formiga10x
    Super Avançado
    Super Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 731
    Registrado : 11/09/2013

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  formiga10x em Seg 24 Ago 2015, 02:12

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

    [Você precisa estar registrado e conectado para ver este link.]

    boa sorte.


    .................................................................................
    Abraço
    Formiga10x

    Sempre que possível poste o bd ou parte dele, com uma explicação bem clara e objetiva do que quer.
    “Um homem não está acabado quando enfrenta a derrota. Ele está acabado quando desiste - Richard Nixon”
    Formiga10x

    "Lembro do exato momento em que me dei conta que boa parte de minha vida foi dedicada a localizar erros em meus próprios programas."
    - Maurice Vicent Wilkes

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Seg 24 Ago 2015, 02:22

    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.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Ter 25 Ago 2015, 01:24

    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

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Qua 26 Ago 2015, 02:14

    Up.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Qui 27 Ago 2015, 02:14

    Up.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Sex 28 Ago 2015, 02:58

    Up.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Sab 29 Ago 2015, 02:54

    Up.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Dom 30 Ago 2015, 04:57

    Up.

    JPaulo
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 8907
    Registrado : 04/11/2009

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  JPaulo em Seg 31 Ago 2015, 11:12

    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


    .................................................................................
    Sucesso e Bons Estudos
    Success and Good Studies

    [Você precisa estar registrado e conectado para ver esta imagem.] [Você precisa estar registrado e conectado para ver este link.]
    [Você precisa estar registrado e conectado para ver esta imagem.] [Você precisa estar registrado e conectado para ver este link.]
    [Você precisa estar registrado e conectado para ver esta imagem.] [Você precisa estar registrado e conectado para ver este link.]

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Ter 01 Set 2015, 00:02

    Obrigado mestre JPaulo,

    Farei os devidos testes e darei breve retorno.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Ter 01 Set 2015, 03:02

    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

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Qua 02 Set 2015, 03:12

    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 & "'")
    [Você precisa estar registrado e conectado para ver esta imagem.]

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Sex 04 Set 2015, 14:34

    Up.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Dom 06 Set 2015, 23:32

    Up.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Seg 07 Set 2015, 23:43

    Up.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Qua 09 Set 2015, 11:53

    Up.

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Qui 10 Set 2015, 19:41

    Up.

    Dilson
    Moderador
    Moderador

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 1602
    Registrado : 11/11/2009

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  Dilson em Qui 10 Set 2015, 20:51

    Olhando o código postado suspeito que acontece assim porque está dentro do loop. Tente implementar o INSERT INTO fora do bloco while.


    .................................................................................
    Atenção:
    => Antes de implementar qualquer dica, faça um backup do seu projeto;
    => Retorne para marcar o Resolvido ou continuar a discussão;
    => Sempre realize pesquisas antes de postar uma pergunta;

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Qui 10 Set 2015, 21:04

    Ok Dilson,

    Vou alterar e retorno.

    Att,

    XPTOS
    Avançado
    Avançado

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 457
    Registrado : 20/01/2014

    Re: [Resolvido]Comparar Registros em duas tabelas.

    Mensagem  XPTOS em Sex 11 Set 2015, 01:33

    Caro Dilson,

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

    Muito obrigado.

      Data/hora atual: Sab 03 Dez 2016, 02:24