[Resolvido]Gerar ID para grupo por bloco em tabela

Senhores bom dia,

tenho um form que gera automaticamente os itens de uma tabela, e nessa tabela se faz um relatório agrupado por "Bloco" exemplo,

E12C...E13C...E14C... ai vem o problema, gostaria de que ao apertar de um botão ele gerasse uma ID para cada grupo desses blocos na tabela IDSaida, tipo assim

E12C - 1110
E12C - 1110
E12C - 1110
E12C - 1110
E13C - 1123
E13C - 1123
E13C - 1123
E13C - 1123
E14C - 1345
E14C - 1345
E14C - 1345
E14C - 1345

no aguardo pessoal

Alguém pessoal ?

Bom dia, Carvalho.

Tenho um sistema que realiza a numeração automática de guias remessa, com base no código da organização para a qual o documentos será expedido, usando um critério semelhante que você pretende usar.
Algumas questões:
1. Quantos elementos o grupo precisa conter para ativar a geração o ID? Talvez tenha que criar uma tabela auxiliar para comparar se a quantidade de elementos de cada grupo atinge o número mínimo para ativar a geração automática;
2. Precisa ordenar os elementos de forma ASC (via filtro SQL) para evitar erros. Vi que o seu BD usa caracteres e números (E12C) para identificar os itens e por isso quando ordenar terá que ser como texto;
3. Qual será o ID inicial para realizar cada geração automática (sugiro que seja baseada na data (dia, mês e ano) para evitar duplicações.

Abraço, Delson

onrigado Delson pela atenção

a quantidade de grupo não tem limites, tipo vai variar muito, desse jeito como conseguir fazer, você teria um exemplo para disponibilizar ?

Public Sub Comando42_Click()
'Caixa de mensagem
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Este procedimento lançar? os números nas Guias de Remessa." & vbCrLf & "Antes de executar este procedimento ? necessário executar o comando n? 6. Lan?ar GU e  endere?o de DESTINO." & vbCrLf & " Deseja realmente continuar?"
Style = vbOKCancel + vbExclamation + vbDefaultButton1
Title = "Lançar os números nas GR!"
Help = "DEMO.HLP"
Ctxt = 1000
   Dim campo_1, campo_2 As String
   Dim estoque_1, estoque_2, cont As Integer
   Dim Data, strSQL As String
   Dim dbs As DAO.Database
   Dim rst As DAO.Recordset
   Set dbs = CurrentDb
   'Set rst = dbs.OpenRecordset("Tbl_expedicao")
   Set rst = dbs.OpenRecordset("Expedir")
   Set rst = dbs.OpenRecordset("Tbl_Expedicao_Consulta")
   DoCmd.OpenQuery "Tbl_Expedicao_Consulta", acViewPreview
   
   Response = MsgBox(Msg, Style, Title, Help, Ctxt)
   If Response = vbOK Then    ' O usuário escolheu OK.
   MyString = "Ok"    ' A resposta foi OK.
   DoCmd.Hourglass -1
   Data = Format(Now(), "yyyymmdd") ' & "." 'captura e formata a data atual
   
   'monta a consulta para deletar todos os dados da tabela Expedir
   DoCmd.SetWarnings False
   strSQL = "DELETE * FROM Expedir"
   DoCmd.RunSQL strSQL 'executa a exclusão dos dados antigos (zerar os dados da tabela auxiliar)
   
   'monta a consulta para inserir os dados da tabela Expedir
   strSQL = "INSERT INTO Expedir ( GU, ContarDeGU ) " & "SELECT GU, ContarDeGU FROM Tbl_Expedicao_Consulta;"
   DoCmd.RunSQL strSQL
   
   'fechar a consulta
   DoCmd.Close acQuery, "Tbl_Expedicao_Consulta"
       
   'monta a consulta atualização
   strSQL = "UPDATE Tbl_OM_Destino INNER JOIN (Expedir INNER JOIN Tbl_Expedicao ON Expedir.GU = Tbl_Expedicao.GU) ON Tbl_OM_Destino.Codom = Tbl_Expedicao.Codom SET Tbl_Expedicao.Estoque = True WHERE ((([Expedir]![ContarDeGU])>=[Qnt_Exp]) AND ((Tbl_Expedicao.Codom)<>'') AND ((Tbl_Expedicao.Expedida)=False)) OR (((DateDiff('d',[Data_BE],Date()))>59));"
   
   DoCmd.RunSQL strSQL 'executa a consulta atualização
   'fechar a consulta
   DoCmd.Close acTable, "Tbl_Expedicao_Consulta"
   
   'Novo
   Me.Filter = "tbl_Expedicao.Expedida=False and tbl_Expedicao.OM<>''" 'Filtro para verificar se não está expedida e o nome da OM não está em branco
   Me.FilterOn = True 'aplica o filtro
   Me.OrderBy = "RM,GU,Estoque" 'ordena os registros nesta sequência
   Me.OrderByOn = True 'aplica a ordenação
   campo_1 = "" 'zera a variável 1
   campo_2 = "" 'zera a variável 2
   estoque_1 = ""
   DoCmd.GoToControl "Codom"
   campo_1 = Me.GU
   campo_2 = Me.GU
   'DoCmd.GoToControl "Estoque"
   estoque_1 = Me.Estoque
   estoque_2 = Me.Estoque
   Do
     Recordset.MoveNext
     On Error GoTo Segunda_parte 'Final_Processo 'Exibe a mensagem de final
        campo_2 = Me.GU
        estoque_2 = Me.Estoque
        If estoque_1 = True And campo_2 = campo_1 Then
           If estoque_2 = False Then
              Me.Estoque = True
           End If
        Else
           campo_1 = campo_2
           estoque_1 = estoque_2
        End If
   Loop Until rst.EOF
   'Novo
Segunda_parte:
   Me.Filter = "tbl_Expedicao.Expedida=False and tbl_Expedicao.OM<>'' and tbl_Expedicao.Estoque=True" 'string do filtro a aplicar
   Me.FilterOn = True 'aplica o filtro
   Me.OrderBy = "RM,GU,OM" 'ordena os registros
   Me.OrderByOn = True 'aplica a ordena??o
   cont = 1 'inicia o contador
   campo_1 = "" 'zera a variável 1
   campo_2 = "" 'zera a variável 2
   
   DoCmd.GoToControl "Codom"
   Me.GR = Data & Format(cont, "000")
   campo_1 = Me.Codom
   campo_2 = Me.Codom
   Do Until rst.EOF
     Recordset.MoveNext
     On Error GoTo Final_Processo 'Exibe a mensagem de final
        campo_2 = Me.Codom
     If campo_2 = campo_1 Then
        Me.GR = CDbl(Data) & Format(cont, "000")
     Else
        cont = cont + 1
        Me.GR = CDbl(Data) & Format(cont, "000")
        campo_1 = campo_2
     End If
   Loop
Final_Processo:
   MsgBox "Processo concluído com sucesso!!!!" 'Exibe a mensagem e encerra a aplicação.
   DoCmd.Hourglass 0
Else  'Usou a opção Cancelar.
   MyString = "Cancel"    ' Executa o cancelamento.
   DoCmd.Close
   DoCmd.SetWarnings True
End If
   
End Sub

Cara obrigado mesmo pela atenção, porem não estou conseguindo adaptar para o meu projeto, teria como mandar um exemplo para eu ver o código em execução, ai eu possa adaptar ao meu projeto! se não for pedir muito ?

A numeracao tem algum criterio, ou pode ser qualquer sequencia tipo E12C-1112, E13C-1113, E14C-1114, E20C-1120?
Estas definicoes podem ajudar muito.

Não tem critério! pode ser aleatório com 6 dígitos. colequei esse valores apenas para ilustrar a minha necessidade .

Enviando o exemplo.

O BD utiliza o campo Codom para realizar o agrupamento e GR é o código gerado.
Abra o Formulário Expedição e clique em no botão Gerar nº da guia de remessa para expedição para começar o procedimento.

Está com um probleminha de entrar num loop de pois de concluir a geração das GR. Feche todo o BD e abra novamente para sair do loop.

Bons estudos, Delson

Obrigado pela ajuda, com seu exemplo tive uma ideia para atender a minha necessidade, porem não consegui incluir essa tratativa para fazer o que eu desejo.

o que preciso é que ele avalie o item que ele está e o abaixo dele, ai travou não estou conseguindo fazer,

Código:

 Pirvate Sub IdAgrupado()

 Dim Rs1 As Recordset
    Dim ID As Double
    Dim ID2 As Double
            Randomize
        ID = Int(Rnd() * 999999)
      ID2 = Int(Rnd() * 999999)

  ' CurrentDb.Execute "delete from TbRelatorioPagoPorBlocoIten;"
        ''

    Set Rs1 = CurrentDb.OpenRecordset("select idsaida, bloco " & _
                                      "from TbRelatorioPagoPorBlocoIten ORDER BY bloco;", , 8)
   
    While Not Rs1.EOF
    If Rs1.Fields(1).Value <> Rs1.Fields(1).Value Then
        Rs1.Edit
            Rs1.Fields(0).Value = ID
                    Rs1.Update 'salvo
        Rs1.MoveNext
    Else
        Rs1.Edit 'vou adicionar
            Rs1.Fields(0).Value = ID2
                    Rs1.Update
        Rs1.MoveNext
    End If
   
    Wend 'fim do loop
   
    Rs1.Close: Set Rs1 = Nothing 'fecho a tabela principal

 

Boa tarde,

Vou descrever uma forma de construir o algoritmo para fazer o procedimento que você quer no seu sistema.
1. passo: odenar de forma crescente os campos que serão utilizados para fazer o agrupamento (esse procedimento é obrigatório. Caso contrário, campos iguais irão receber códigos de agrupamento diferentes);
2. passo: vai para o início do arquivo e a variável ID recebe o primeiro item para comparação (ex: ABC) e escreve o primeiro código do agrupamento campo_do_agrupamento  (exemplo usando o ano, mês e data de hoje, separados por ponto e mais três dígitos: 2018.07.09.001);
3. passo: vai para o próximo registro e a variável ID2 recebe o segundo item para comparação(ex: ABC) e compara se é igual à variável ID; caso for igual, escreve o mesmo código de agrupamento (ex: 2018.07.09.001) e segue para o terceiro item e assim em diante; caso for diferente (ex: ABD), a variável ID recebe a variável ID2 e adiciona uma unidade ao código do agrupamento (ex: 2018.07.09.002). E prossegue assim até o final do arquivo.

Abraço, Delson

Muito obrigado a todos pela ajuda, também com ajuda do nosso amigo Avelino que me forneceu o código abaixo,

Tópico resolvido.

Código:

Private Sub Comando0_Click()
Dim rs As DAO.Recordset
Dim strSql$
Dim uid&
Dim cod$
Dim Rn As Double 'alterado aqui
  Randomize  'alterado aqui
    Rn = Int(Rnd() * 99999) 'alterado aqui

    CurrentDb.Execute "Update tblteste SET Id = 0" 'alterado aqui
   
'retorna com o recordset, somente dos registros sem o ID
strSql = "SELECT Codigo,ID FROM tblTeste WHERE id =0 ORDER BY Codigo;"
'Abre o recordset
Set rs = CurrentDb.OpenRecordset(strSql)
'captura o último ID lançado
uid = DMax("id", "tblTeste")
'percorrer os registros para numerar o ID
Do While Not rs.EOF
    'verifica se mudou o código para acrecentar 1 ao ID
    If cod <> rs!codigo Then
    uid = uid + Rn 'alterado aqui
        cod = rs!codigo
    End If
    'atualiza a tabela com o novo ID
    rs.Edit
        rs!id = uid
    rs.Update
    rs.MoveNext
Loop
rs.Close
Set rs = Nothing
MsgBox "Tabela Atualizada...", vbInformation, "Aviso"
DoCmd.OpenTable "tblTeste"
End Sub