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]Mudar de linha a cada nome

    Compartilhe
    avatar
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3485
    Registrado : 06/11/2009

    [Resolvido]Mudar de linha a cada nome

    Mensagem  Assis em 18/3/2018, 14:07

    Boas tardes Amigos

    No formulário que posto, como mudar de linha nos campos "Manhã", "Tarde", "Noite", "Descanso", "Férias" , sempre que mudar o nome.

    Os nomes estão separados por virgula.

    Exemplo

    Dia 01/03/2018 Manhã ficava assim etc. :

    José Carlos,
    José Luís,
    Teixeira,
    Portelinha

    Obrigado


    .................................................................................
    *** Só sei que nada sei ***
    avatar
    Alexandre Neves
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6855
    Registrado : 05/11/2009

    Re: [Resolvido]Mudar de linha a cada nome

    Mensagem  Alexandre Neves em 18/3/2018, 20:09

    Boa noite, Assis
    Passa os campos para texto longo
    substitui as vírgulas por
    (através da função replace)
    e voilá


    .................................................................................
    Access 2010. Mande bd que dê para testar (indique a versão). Não peça para fazer o que já tem feito. Dê todos os detalhes.
    Não coloquem entraves como senhas, esconder controlos, etc. Disponibilizem o mais limpo possível
    Só respondo a mensagens privadas, se forem de assunto privado; às outras não respondo.
    Quem trabalha e mata a fome não come o pão de ninguém; mas quem não trabalha e come, come sempre o pão de alguém. António Aleixo
    avatar
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3485
    Registrado : 06/11/2009

    Re: [Resolvido]Mudar de linha a cada nome

    Mensagem  Assis em 19/3/2018, 11:17

    Bom dia Alexandre

    As virgulas estão lá por esta Rotina da sua autoria.

    Obrigado

    Option Compare Database
    Option Explicit
    'código criado por Alexandre Neves
    'em 2012-12-15
    'para dteixa
    'do fórum MaximoAccess

    Sub CriaTurnos()
    On Error Resume Next
    Dim RstOperadores As Dao.Recordset, RstTurnos As Dao.Recordset, RstAusencias As Dao.Recordset
    Dim dtData As Date, Inicio As Date, Fim As Date, Turno As Byte

    Set RstOperadores = CurrentDb.OpenRecordset("SELECT * FROM Operadores;")
    Set RstTurnos = CurrentDb.OpenRecordset("SELECT * FROM Turnos;")
    Set RstAusencias = CurrentDb.OpenRecordset("SELECT Letra,Inicio,Fim FROM Ausencias LEFT JOIN Operadores ON Ausencias.Operador=Operadores.Nome;")
    Inicio = Forms!Rotina!Inicio
    Fim = Forms!Rotina!Fim

    ''''
    CurrentDb.Execute "DELETE * FROM Turnos"
    ''''
    For dtData = Inicio To Fim
    RstTurnos.AddNew
    RstTurnos(1) = dtData

    RstAusencias.MoveFirst
    Do While Not RstAusencias.EOF
    If dtData >= RstAusencias("Inicio") And dtData <= RstAusencias("Fim") Then RstTurnos("Ausencia") = RstTurnos("Ausencia") & RstAusencias("Letra") & ","
    RstAusencias.MoveNext
    Loop
    If Not IsNull(RstTurnos("Ausencia")) Then RstTurnos("Ausencia") = Mid(RstTurnos("Ausencia"), 1, Len(RstTurnos("Ausencia")) - 1)
    For Turno = 1 To Forms!Rotina!NTurnos
    If RstOperadores.EOF Then RstOperadores.MoveFirst
    Verifica1:
    If InStr(1, RstTurnos("Ausencia"), RstOperadores("Letra")) > 0 Then
    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    GoTo Verifica1
    End If

    RstTurnos(Turno + 1) = RstOperadores("Letra")
    RstOperadores.MoveNext
    If RstOperadores.EOF Then RstOperadores.MoveFirst
    Verifica2:
    If InStr(1, RstTurnos("Ausencia"), RstOperadores("Letra")) > 0 Then
    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    GoTo Verifica2
    End If

    RstTurnos(Turno + 1) = RstTurnos(Turno + 1) & "," & RstOperadores("Letra")
    RstOperadores.MoveNext
    If RstOperadores.EOF Then RstOperadores.MoveFirst
    Verifica3:
    If InStr(1, RstTurnos("Ausencia"), RstOperadores("Letra")) > 0 Then
    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    GoTo Verifica3
    End If

    RstTurnos(Turno + 1) = RstTurnos(Turno + 1) & "," & RstOperadores("Letra")
    RstOperadores.MoveNext
    If RstOperadores.EOF Then RstOperadores.MoveFirst
    Verifica4:
    If InStr(1, RstTurnos("Ausencia"), RstOperadores("Letra")) > 0 Then
    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    GoTo Verifica4
    End If

    RstTurnos(Turno + 1) = RstTurnos(Turno + 1) & "," & RstOperadores("Letra")
    RstOperadores.MoveNext

    Next

    RstTurnos.Update

    Next

    RstTurnos.MoveFirst
    Do While Not RstTurnos.EOF
    RstOperadores.MoveFirst

    RstTurnos.Edit

    Do While Not RstOperadores.EOF

    If InStr(1, RstTurnos(2) & RstTurnos(3) & RstTurnos(4) & RstTurnos("Ausencia"), RstOperadores("Letra")) = 0 Then
    RstTurnos("Descanso") = RstTurnos("Descanso") & RstOperadores("Letra") & ","
    End If

    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    Loop
    If Right(RstTurnos("Descanso"), 1) = "," Then RstTurnos("Descanso") = Mid(RstTurnos("Descanso"), 1, Len(RstTurnos("Descanso")) - 1)
    RstTurnos.Update
    RstTurnos.MoveNext
    Loop
    Set RstTurnos = Nothing: Set RstOperadores = Nothing

    End Sub


    .................................................................................
    *** Só sei que nada sei ***
    avatar
    Alexandre Neves
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6855
    Registrado : 05/11/2009

    Re: [Resolvido]Mudar de linha a cada nome

    Mensagem  Alexandre Neves em 19/3/2018, 12:25

    Bom dia, Assis

    Código:
    Option Compare Database
    Option Explicit
    'código criado por Alexandre Neves
    'em 2012-12-15
    'para dteixa
    'do fórum MaximoAccess

    Sub CriaTurnos()
    On Error Resume Next
    Dim RstOperadores As Dao.Recordset, RstTurnos As Dao.Recordset, RstAusencias As Dao.Recordset
    Dim dtData As Date, Inicio As Date, Fim As Date, Turno As Byte

    Set RstOperadores = CurrentDb.OpenRecordset("SELECT * FROM Operadores;")
    Set RstTurnos = CurrentDb.OpenRecordset("SELECT * FROM Turnos;")
    Set RstAusencias = CurrentDb.OpenRecordset("SELECT Letra,Inicio,Fim FROM Ausencias LEFT JOIN Operadores ON Ausencias.Operador=Operadores.Nome;")
    Inicio = Forms!Rotina!Inicio
    Fim = Forms!Rotina!Fim

    ''''
    CurrentDb.Execute "DELETE * FROM Turnos"
    ''''
    For dtData = Inicio To Fim
    RstTurnos.AddNew
    RstTurnos(1) = dtData

    RstAusencias.MoveFirst
    Do While Not RstAusencias.EOF
    If dtData >= RstAusencias("Inicio") And dtData <= RstAusencias("Fim") Then RstTurnos("Ausencia") = RstTurnos("Ausencia") & RstAusencias("Letra") & "<br>"
    RstAusencias.MoveNext
    Loop
    If Not IsNull(RstTurnos("Ausencia")) Then RstTurnos("Ausencia") = Mid(RstTurnos("Ausencia"), 1, Len(RstTurnos("Ausencia")) - 1)
    For Turno = 1 To Forms!Rotina!NTurnos
    If RstOperadores.EOF Then RstOperadores.MoveFirst
    Verifica1:
    If InStr(1, RstTurnos("Ausencia"), RstOperadores("Letra")) > 0 Then
    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    GoTo Verifica1
    End If

    RstTurnos(Turno + 1) = RstOperadores("Letra")
    RstOperadores.MoveNext
    If RstOperadores.EOF Then RstOperadores.MoveFirst
    Verifica2:
    If InStr(1, RstTurnos("Ausencia"), RstOperadores("Letra")) > 0 Then
    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    GoTo Verifica2
    End If

    RstTurnos(Turno + 1) = RstTurnos(Turno + 1) & "<br>" & RstOperadores("Letra")
    RstOperadores.MoveNext
    If RstOperadores.EOF Then RstOperadores.MoveFirst
    Verifica3:
    If InStr(1, RstTurnos("Ausencia"), RstOperadores("Letra")) > 0 Then
    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    GoTo Verifica3
    End If

    RstTurnos(Turno + 1) = RstTurnos(Turno + 1) & "<br>" & RstOperadores("Letra")
    RstOperadores.MoveNext
    If RstOperadores.EOF Then RstOperadores.MoveFirst
    Verifica4:
    If InStr(1, RstTurnos("Ausencia"), RstOperadores("Letra")) > 0 Then
    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    GoTo Verifica4
    End If

    RstTurnos(Turno + 1) = RstTurnos(Turno + 1) & "<br>" & RstOperadores("Letra")
    RstOperadores.MoveNext

    Next

    RstTurnos.Update

    Next

    RstTurnos.MoveFirst
    Do While Not RstTurnos.EOF
    RstOperadores.MoveFirst

    RstTurnos.Edit

    Do While Not RstOperadores.EOF

    If InStr(1, RstTurnos(2) & RstTurnos(3) & RstTurnos(4) & RstTurnos("Ausencia"), RstOperadores("Letra")) = 0 Then
    RstTurnos("Descanso") = RstTurnos("Descanso") & RstOperadores("Letra") & "<br>"
    End If

    If RstOperadores.EOF Then RstOperadores.MoveFirst Else RstOperadores.MoveNext
    Loop
    If Right(RstTurnos("Descanso"), 1) = "<br>" Then RstTurnos("Descanso") = Mid(RstTurnos("Descanso"), 1, Len(RstTurnos("Descanso")) - 1)
    RstTurnos.Update
    RstTurnos.MoveNext
    Loop
    Set RstTurnos = Nothing: Set RstOperadores = Nothing

    End Sub


    .................................................................................
    Access 2010. Mande bd que dê para testar (indique a versão). Não peça para fazer o que já tem feito. Dê todos os detalhes.
    Não coloquem entraves como senhas, esconder controlos, etc. Disponibilizem o mais limpo possível
    Só respondo a mensagens privadas, se forem de assunto privado; às outras não respondo.
    Quem trabalha e mata a fome não come o pão de ninguém; mas quem não trabalha e come, come sempre o pão de alguém. António Aleixo
    avatar
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3485
    Registrado : 06/11/2009

    Re: [Resolvido]Mudar de linha a cada nome

    Mensagem  Assis em 19/3/2018, 14:22

    Boa tarde Alexandre


    Ficou assim:


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


    .................................................................................
    *** Só sei que nada sei ***
    avatar
    Alexandre Neves
    Moderador Global
    Moderador Global

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 6855
    Registrado : 05/11/2009

    Re: [Resolvido]Mudar de linha a cada nome

    Mensagem  Alexandre Neves em 19/3/2018, 15:54

    E o campo foi mudado para texto longo?


    .................................................................................
    Access 2010. Mande bd que dê para testar (indique a versão). Não peça para fazer o que já tem feito. Dê todos os detalhes.
    Não coloquem entraves como senhas, esconder controlos, etc. Disponibilizem o mais limpo possível
    Só respondo a mensagens privadas, se forem de assunto privado; às outras não respondo.
    Quem trabalha e mata a fome não come o pão de ninguém; mas quem não trabalha e come, come sempre o pão de alguém. António Aleixo
    avatar
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3485
    Registrado : 06/11/2009

    Re: [Resolvido]Mudar de linha a cada nome

    Mensagem  Assis em 19/3/2018, 15:55

    Sim Alexandre


    .................................................................................
    *** Só sei que nada sei ***
    avatar
    Assis
    Maximo VIP
    Maximo VIP

    Respeito às Regras 100%

    Sexo : Masculino
    Localização : Portugal
    Mensagens : 3485
    Registrado : 06/11/2009

    Re: [Resolvido]Mudar de linha a cada nome

    Mensagem  Assis em 19/3/2018, 21:43

    Boa noite Alexandre

    Resolvido


    .................................................................................
    *** Só sei que nada sei ***

      Data/hora atual: 18/8/2018, 15:42