MaximoAccess

Caro Usuário, antes de postar pela primeira vez, leia as regras do fórum.

Obrigado

Administração do MaximoAccess

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

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

    Compartilhe

    Chamon Consultoria
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 196
    Registrado : 31/08/2012

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

    Mensagem  Chamon Consultoria em Qui 23 Mar 2017, 00:16

    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!
    avatar
    CassioFabre
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 434
    Registrado : 18/01/2013

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

    Mensagem  CassioFabre em Qui 23 Mar 2017, 12:14

    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.

    Chamon Consultoria
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 196
    Registrado : 31/08/2012

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

    Mensagem  Chamon Consultoria em Sex 24 Mar 2017, 02:40

    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!


    avatar
    CassioFabre
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 434
    Registrado : 18/01/2013

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

    Mensagem  CassioFabre em Sex 24 Mar 2017, 11:27

    Bom dia,

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

    Abraço.

    Chamon Consultoria
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 196
    Registrado : 31/08/2012

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

    Mensagem  Chamon Consultoria em Ter 28 Mar 2017, 15:33

    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
    avatar
    CassioFabre
    Developer
    Developer

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 434
    Registrado : 18/01/2013

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

    Mensagem  CassioFabre em Ter 28 Mar 2017, 20:05

    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.

    Chamon Consultoria
    Intermediário
    Intermediário

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Brasil
    Mensagens : 196
    Registrado : 31/08/2012

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

    Mensagem  Chamon Consultoria em Seg 22 Maio 2017, 02:29

    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

      Data/hora atual: Sab 23 Set 2017, 06:45