[Resolvido]Agrupar Produtos que tenham o mesmo código em um formulário contínuo

Boa noite!

Bd em Access 2010.

O sistema possui o formulário Vendas com um subformulário onde são lançados os produtos, suas quantidades e valores.
Como exemplo, diariamente são geradas várias vendas para um mesmo cliente e com diversos produtos.
Nessas diversas vendas, o cliente acaba comprando os mesmos produtos (Produtos com mesmo código id).

O sistema possui um comando em uma caixa de combinação, que permite agrupar (uma a uma) todas vendas de um mesmo cliente, em uma única venda. Porém, não agrupa os produtos que têm o mesmo id. Assim, se por exemplo, foram feitas dez vendas com o produto de Código id 001, o sistema gera no subformulário, dez linhas com as quantidades e valores de cada venda desse produto.
O ideal seria se o sistema agrupasse as dez linhas desse produto em apenas uma, somando suas quantidades e valores.

Como posso fazer isso?

Desde já agradeço!

Bom dia,

Isso seria viável pensando que o cliente compraria o mesmo produto, nas mesmas quantidades e pelo mesmo preço em todas as vezes. Mas caso isso não seja verdade, mesmo ainda é interessante implementar essa função?

Abraço.

Cassio,

não sei se entendi bem sua pergunta... mas sim, a função precisa ser implementada de forma que acumule em uma única linha o somatório de todos os produtos que possuam o mesmo código (id) e com o mesmo valor unitário.

Exemplo de como é:

Cod Descrição Quantidade Vr Unit Total
001 Produto A 100 1,00 100,00
001 Produto A 200 1,00 200,00
001 Produto A 150 1,00 150,00
003 Produto C 900 2,00 1800,00


Como deveria ficar aplicando a função:

Cod Descrição Quantidade Vr Unit Total
001 Produto A 450 1,00 450,00
003 Produto C 900 2,00 1800,00


Gostaria de pelo menos um exemplo de função que faça isso, para que eu possa adapta-la...


Obrigado!

Bom dia,

pra ficar mais fácil de implementar, poste a parte do bd que está relacionado com o seu problema.

Abraço.

Bom dia!



Consegui um pequeno avanço. Ainda necessita de algum ajuste no código, mas não estou encontrando a falha...

Sem a parte do código incluída em 28-03-2017, o sistema adiciona todos os itens do pedido selecionado à venda atual.

Com a alteração no código o resultado foi:


Atualiza a quantidade e valor apenas do primeiro item (se o código do produto for comum na venda atual e na selecionada para agrupar)

Não atualiza os demais itens (se o código do produto também for comum na venda atual e na selecionada para agrupar)

Não adiciona os demais itens que têm o código do produto diferente, permanecendo apenas os itens da venda atual. (quando a venda a ser agrupada possuir outros itens com o código do produto diferente dos existentes na venda atual)

Código:

Private Sub Agrupar_AfterUpdate()
    Dim txtCodPro As Integer
    Dim nCFOP
    Dim xPedidoAgrupado
  
    xPedidoAgrupado = Agrupar.Column(0)
    
    Beep
    Response = MsgBox("Confirma o agrupamento do pedido " & "" & xPedidoAgrupado & " ao pedido atual?", CM_SIMNAO + CM_ICONEINTERROGACAO, "Agrupar")
    If Response = IDNAO Then
        Exit Sub
    End If    
  
    Set dbs = CurrentDb
    strSql = "SELECT * FROM tbl_VendasItens WHERE NUMEROPEDIDO = " & "'" & xPedidoAgrupado & "'"
    Set rst = dbs.OpenRecordset(strSql)
                        
    Do While Not rst.EOF
        txtCodPro = rst("CODPRO")
        txtVarPro = DLookup("[ccVarPro]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtNomPro = DLookup("[ccNomPro]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtBarras = DLookup("[ccBarras]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtMedida = DLookup("[ccMedida]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        
        txtNCM = DLookup("[ccNCM]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtEstoque = DLookup("[ccEstoque]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtAliquotaIBPT = DLookup("[ccAliquotaIBPT]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtCST = DLookup("[ccCST]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtpIPI = DLookup("[ccIPI]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtIPICST = DLookup("[ccIPICST]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtPreçoCusto = DLookup("[ccPreçoCusto]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtPreçoVenda = rst("UNITARIO")
        txtTipoProduto = Busca("ccTipo", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtALIQUOTAICMS = Busca("ccICMSSAIDA", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtMVA = Busca("ccMVA", "viewProdutos", "[CODPRO]=" & txtCodPro & "")        
            
 
        nCFOP = txtCFOP      
      
            
        Set db = CurrentDb()
        Set RS = db.OpenRecordset("tbl_VendasItens")
'--------------------------------------------------------------------------------------------------------------'Incluído para testar em 28-03-2017
        If DCount("CODPRO", "tbl_VendasItens", "CODPRO =" & txtCodPro & "") Then
    
        CurrentDb.Execute "Update tbl_VendasItens Set QUANTIDADE = QUANTIDADE +(" & rst("QUANTIDADE") & ") Where CODPRO =" & txtCodPro & " and NUMEROPEDIDO ='" & Me.txtNUMEROPEDIDO & "'"
        CurrentDb.Execute "Update tbl_VendasItens Set TOTAL =(QUANTIDADE * UNITARIO) Where CODPRO =" & txtCodPro & " and NUMEROPEDIDO ='" & Me.txtNUMEROPEDIDO & "'"
        
        LimpaCampos
        VendaSubConsulta.Requery
        CalculaSubTotal
        
        Exit Sub
        Else
'------------------------------------------------------------------------------------------------------------------------------------------


        RS.AddNew
            RS("NUMEROPEDIDO") = txtNUMEROPEDIDO
            RS("NUMERONF") = txtNUMERONF
            RS("CODPRO") = txtCodPro
            RS("CODIGO") = txtVarPro
            RS("BARRAS") = txtBarras
            RS("DESCRICAO") = txtNomPro
            RS("MEDIDA") = txtMedida
            RS("NCM") = txtNCM
            RS("CST") = txtCST
            RS("CSOSN") = txtCSOSN
            RS("QUANTIDADE") = rst("QUANTIDADE")
            RS("CUSTO") = Format(txtPreçoCusto, "standard")
            RS("UNITARIO") = Format(txtPreçoVenda, "standard")
            txtSubTotal = Format((rst("QUANTIDADE") * txtPreçoVenda), "standard")
            RS("TOTAL") = Format(txtSubTotal, "##,##0.00")            
            RS("CFOP") = txtCFOP      
                          
            RS("ITEM") = nItem
            RS.Update
        rst.MoveNext
        
        nItem = Format(nItem + 1, "000")
'------------------------------------------------------------------------------------------------------------------------------
        End If 'Incluído em 28-03-2017 para fechar: If DCount("CODPRO", "tbl_VendasItens", "CODPRO =" & txtCodPro & "") Then
'------------------------------------------------------------------------------------------------------------------------------
    Loop      
    
    LimpaCampos
    VendaSubConsulta.Requery
    CalculaSubTotal    
  
    
VoltaErro:

Exit Sub

erro:
    Beep
    MsgBox Error$, vbCritical, "Edição"
    Resume VoltaErro
End Sub


Boa tarde,

Apenas dessa forma não consigo visualizar o que pode estar acontecendo. Pra mim está tudo ok. Se possível, poste parte do bd que está tentando mexer.

Abraço.

Segue código corrigido. As correções foram destacadas no código.

No mais, obrigado pela atenção.

Abraço.

Código:

Private Sub Agrupar_AfterUpdate()
    Dim txtCodPro As Integer
    Dim nCFOP
    Dim xPedidoAgrupado

    xPedidoAgrupado = Agrupar.Column(0)

    Beep
    Response = MsgBox("Confirma o agrupamento do pedido " & "" & xPedidoAgrupado & " ao pedido atual?", CM_SIMNAO + CM_ICONEINTERROGACAO, "Agrupar")
    If Response = IDNAO Then
        Exit Sub
    End If

    Set dbs = CurrentDb
    strSql = "SELECT * FROM tbl_VendasItens WHERE NUMEROPEDIDO = " & "'" & xPedidoAgrupado & "'"
    Set rst = dbs.OpenRecordset(strSql)

    '  Do While Not rst.EOF 'Desativado
    While (Not rst.EOF) 'Incluído
        txtCodPro = rst("CODPRO")
        txtVarPro = DLookup("[ccVarPro]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtNomPro = DLookup("[ccNomPro]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtBarras = DLookup("[ccBarras]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtMedida = DLookup("[ccMedida]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")

        txtNCM = DLookup("[ccNCM]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtEstoque = DLookup("[ccEstoque]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtAliquotaIBPT = DLookup("[ccAliquotaIBPT]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtCST = DLookup("[ccCST]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtpIPI = DLookup("[ccIPI]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtIPICST = DLookup("[ccIPICST]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtPreçoCusto = DLookup("[ccPreçoCusto]", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtPreçoVenda = rst("UNITARIO")
        txtTipoProduto = Busca("ccTipo", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtALIQUOTAICMS = Busca("ccICMSSAIDA", "viewProdutos", "[CODPRO]=" & txtCodPro & "")
        txtMVA = Busca("ccMVA", "viewProdutos", "[CODPRO]=" & txtCodPro & "")


        nCFOP = txtCFOP


        Set db = CurrentDb()
        Set RS = db.OpenRecordset("tbl_VendasItens")
        '--------------------------------------------------------------------------------------------------------------'Desativado
        '        If DCount("CODPRO", "tbl_VendasItens", "CODPRO =" & txtCodPro & "") Then

        '        CurrentDb.Execute "Update tbl_VendasItens Set QUANTIDADE = QUANTIDADE +(" & rst("QUANTIDADE") & ") Where CODPRO =" & txtCodPro & " and NUMEROPEDIDO ='" & Me.txtNUMEROPEDIDO & "'"
        '        CurrentDb.Execute "Update tbl_VendasItens Set TOTAL =(QUANTIDADE * UNITARIO) Where CODPRO =" & txtCodPro & " and NUMEROPEDIDO ='" & Me.txtNUMEROPEDIDO & "'"

        '        LimpaCampos
        '        VendaSubConsulta.Requery
        '        CalculaSubTotal

        '        Exit Sub
        '        Else
        '------------------------------------------------------------------------------------------------------------------------------------------
        If DCount("CODPRO", "tbl_VendasItens", "CODPRO =" & txtCodPro & " and NUMEROPEDIDO='" & Me.txtNUMEROPEDIDO & "'") Then    'Incluído

            CurrentDb.Execute "Update tbl_VendasItens Set QUANTIDADE = QUANTIDADE +(" & rst("QUANTIDADE") & ") Where CODPRO =" & txtCodPro & " and NUMEROPEDIDO ='" & Me.txtNUMEROPEDIDO & "'"
            CurrentDb.Execute "Update tbl_VendasItens Set TOTAL =(QUANTIDADE * UNITARIO) Where CODPRO =" & txtCodPro & " and NUMEROPEDIDO ='" & Me.txtNUMEROPEDIDO & "'"

        Else

            '-----------------------------------------------------------------------------------------------------------------------------------------

            RS.AddNew
            RS("NUMEROPEDIDO") = txtNUMEROPEDIDO
            RS("NUMERONF") = txtNUMERONF
            RS("CODPRO") = txtCodPro
            RS("CODIGO") = txtVarPro
            RS("BARRAS") = txtBarras
            RS("DESCRICAO") = txtNomPro
            RS("MEDIDA") = txtMedida
            RS("NCM") = txtNCM
            RS("CST") = txtCST
            RS("CSOSN") = txtCSOSN
            RS("QUANTIDADE") = rst("QUANTIDADE")
            RS("CUSTO") = Format(txtPreçoCusto, "standard")
            RS("UNITARIO") = Format(txtPreçoVenda, "standard")
            txtSubTotal = Format((rst("QUANTIDADE") * txtPreçoVenda), "standard")
            RS("TOTAL") = Format(txtSubTotal, "##,##0.00")
            RS("CFOP") = txtCFOP

            RS("ITEM") = nItem
            RS.Update
            rst.MoveNext

            nItem = Format(nItem + 1, "000")

        End If
        '  Loop 'Desativado

        rst.MoveNext    'Incluído

    Wend    'Incluído

    LimpaCampos
    VendaSubConsulta.Requery
    CalculaSubTotal


VoltaErro:

    Exit Sub

erro:
    Beep
    MsgBox Error$, vbCritical, "Edição"
    Resume VoltaErro
End Sub