un problème insoluble pour moi

birac · 18 Septembre 2012

Bonjour

J'ai un fichier mailing spécifique, dans le cadre de formation médicale en e-learning à gérer régulièrement.

Je vous mets un exemple de ce fichier en pièce jointe. Vous verrez que j'ai déjà mis des macros qui se déclenchent individuellement, en fonction de critères précis et jusque là tout va bien.

Mon soucis est que je dois faire apparaître l'ensemble des formations pour chaque personne (représentées ici par H, M et P)

sachant que je devrais faire disparaître les doublons dans les colonnes IDENT et MAIL, y a t'il une possibilité de macro qui me permettrais, avant de lancer celles qui existent, que chaque fois qu'un IDENT à plusieurs formations différentes, ces dernières s'affichent sur la première ligne présentant cet IDENT, et quelles soient ensuite fixées.

En clair, pour mon premier IDENT, il apparait sur 3 lignes, avec une formation différente sur chaque ligne (H, M et P) et je souhaite donc, en cliquant sur un bouton, que les trois lettres se mettent sur la première ligne. Cette macro, si elle est réalisable, devrait prendre en compte l'ensemble du fichier.

J'espère m'être fait comprendre et que vous pourrez m'aider à résoudre ce problème.

En vous remerciant par avance

Cordialement

Philippe

Dormeur74 · 18 Septembre 2012

Re : un problème insoluble pour moi

Ce n'est pas très difficile, mais je voudrais être certain d'avoir bien compris (reformulation) :
On trouve l'identifiant EM000001 sur les lignes 2, 15 et 22. Si j'ai bien compris, tu voudrais qu'on trouve la valeur "HMP" dans la cellule R2 et que les lignes 15 et 22 passent à la trappe.

Si je n'ai pas interprété, je peux te faire ça demain matin si personne n'a eu le temps de te dépanner.

Dormeur74 · 19 Septembre 2012

Re : un problème insoluble pour moi

Tu peux toujours essayer cette macro, mais ne travaille pas sur le fichier original :

Code:

Sub Macro1()
    Dim chemin As String, fichier As String
    Dim nbLignes As Integer, y As Integer, compteur As Integer
    Dim tableau() As Integer
    
    ' On sauvegarde le fichier avec l'extension .tmp pour des raisons de sécurité
    fichier = ThisWorkbook.FullName
    fichier = Left(fichier, Len(fichier) - 4) & ".tmp"
    ActiveWorkbook.SaveAs Filename:=fichier

    ' On commence par trier la feuille selon les identifiants
    Cells.Select
    Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ActiveWindow.SmallScroll Down:=-9
    
    ' On compte le nombre de lignes
    nbLignes = Cells(Rows.Count, 2).End(xlUp).Row
    
    For y = 2 To nbLignes
        ' Si triplet
        If Cells(y, 3) = Cells(y + 1, 3) And Cells(y, 3) = Cells(y + 2, 3) Then
            Cells(y, 17) = Cells(y, 17) & Cells(y + 1, 17) & Cells(y + 2, 17)
            compteur = compteur + 1
            ReDim Preserve tableau(compteur)
            tableau(compteur) = y + 1
            compteur = compteur + 1
            ReDim Preserve tableau(compteur)
            tableau(compteur) = y + 2
            y = y + 2
        End If
        ' Si doublet
        If Cells(y, 3) = Cells(y + 1, 3) Then
            Cells(y, 17) = Cells(y, 17) & Cells(y + 1, 17)
            compteur = compteur + 1
            ReDim Preserve tableau(compteur)
            tableau(compteur) = y + 1
            y = y + 1
        End If
    Next y
    
    ' On détruit les lignes du bas vers le haut
    For y = UBound(tableau) To 1 Step -1
        Rows(tableau(y)).EntireRow.Delete Shift:=xlUp
    Next y
End Sub

camarchepas · 19 Septembre 2012

Re : un problème insoluble pour moi

Bonjour Birac, Dormeur, les membres du Forum et tous les lecteurs passant par ce file.

Je propose une solution utilisant l'objet Dictionnaire pour tester les doublons.

Code:

Sub CompletePremier()
Dim MonDico As Object
Dim LigneCourante As Long, LigneReference As Long
Dim Lecture As String

  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  LigneCourante = 2
  
  'Boucle de la 1° ligne de données à la derniére ligne non vide de la colonne B
  Do While LigneCourante <= Range("B" & Rows.Count).End(xlUp).Row
    Lecture = Cells(LigneCourante, "D")
    
    'Si élément non connu ajout au dico et mémorise numéro de ligne, puis passe à la ligne suivante
    If Not MonDico.Exists(Lecture) Then
      MonDico(Lecture) = LigneCourante
      LigneCourante = LigneCourante + 1
      
     'Si élément connu dans dico alors lecture de la mémoire de ligne, concatene la colonne R puis efface la ligne courante
    Else
      LigneReference = MonDico(Lecture)
      Range("R" & LigneReference) = Range("R" & LigneReference) & "," & Range("R" & LigneCourante)
      Rows(LigneCourante).EntireRow.Delete
    End If
  Loop
    
  Application.ScreenUpdating = True
End Sub

birac · 19 Septembre 2012

Re : un problème insoluble pour moi

Dormeur74 à dit:

Tu peux toujours essayer cette macro, mais ne travaille pas sur le fichier original :

Code:

Sub Macro1()
    Dim chemin As String, fichier As String
    Dim nbLignes As Integer, y As Integer, compteur As Integer
    Dim tableau() As Integer
    
    ' On sauvegarde le fichier avec l'extension .tmp pour des raisons de sécurité
    fichier = ThisWorkbook.FullName
    fichier = Left(fichier, Len(fichier) - 4) & ".tmp"
    ActiveWorkbook.SaveAs Filename:=fichier

    ' On commence par trier la feuille selon les identifiants
    Cells.Select
    Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ActiveWindow.SmallScroll Down:=-9
    
    ' On compte le nombre de lignes
    nbLignes = Cells(Rows.Count, 2).End(xlUp).Row
    
    For y = 2 To nbLignes
        ' Si triplet
        If Cells(y, 3) = Cells(y + 1, 3) And Cells(y, 3) = Cells(y + 2, 3) Then
            Cells(y, 17) = Cells(y, 17) & Cells(y + 1, 17) & Cells(y + 2, 17)
            compteur = compteur + 1
            ReDim Preserve tableau(compteur)
            tableau(compteur) = y + 1
            compteur = compteur + 1
            ReDim Preserve tableau(compteur)
            tableau(compteur) = y + 2
            y = y + 2
        End If
        ' Si doublet
        If Cells(y, 3) = Cells(y + 1, 3) Then
            Cells(y, 17) = Cells(y, 17) & Cells(y + 1, 17)
            compteur = compteur + 1
            ReDim Preserve tableau(compteur)
            tableau(compteur) = y + 1
            y = y + 1
        End If
    Next y
    
    ' On détruit les lignes du bas vers le haut
    For y = UBound(tableau) To 1 Step -1
        Rows(tableau(y)).EntireRow.Delete Shift:=xlUp
    Next y
End Sub

Bonjour et merci beaucoup de ta réponse.

La macro est apparemment très bien, mon seul problème (et oui, saperlipopette, y'a toujours un problème

) c'est que c'est la colonne autorise qui s'incrémente (colonne Q) et non la colonne R avec les lettres H, M et P.

Je n'arrive pas à voir dans ta macro ou se situe l'appel des colonnes. si tu pouvais m'éclairer.

Un grand merci

Philippe

birac · 19 Septembre 2012

camarchepas à dit:

Bonjour Birac, Dormeur, les membres du Forum et tous les lecteurs passant par ce file.

Je propose une solution utilisant l'objet Dictionnaire pour tester les doublons.

Code:

Sub CompletePremier()
Dim MonDico As Object
Dim LigneCourante As Long, LigneReference As Long
Dim Lecture As String

  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  LigneCourante = 2
  
  'Boucle de la 1° ligne de données à la derniére ligne non vide de la colonne B
  Do While LigneCourante <= Range("B" & Rows.Count).End(xlUp).Row
    Lecture = Cells(LigneCourante, "D")
    
    'Si élément non connu ajout au dico et mémorise numéro de ligne, puis passe à la ligne suivante
    If Not MonDico.Exists(Lecture) Then
      MonDico(Lecture) = LigneCourante
      LigneCourante = LigneCourante + 1
      
     'Si élément connu dans dico alors lecture de la mémoire de ligne, concatene la colonne R puis efface la ligne courante
    Else
      LigneReference = MonDico(Lecture)
      Range("R" & LigneReference) = Range("R" & LigneReference) & "," & Range("R" & LigneCourante)
      Rows(LigneCourante).EntireRow.Delete
    End If
  Loop
    
  Application.ScreenUpdating = True
End Sub

Bonjour et merci à toi aussi

Celle-ci marche très bien, bien que je ne la comprenne pas totalement, mais bon, je suis encore un débutant en macro.

Juste une petite question : est il possible de rajouter dans cette macro, selon le même principe que la remontée des formation H,M,P, de remonter de la même manière les données de la colonne O ? (12.0X, etc)

Grand merci à toi et à toutes celles et tous ceux qui participent à ce forum pour aider les autres.

Cordialement

Philippe

Dormeur74 · 19 Septembre 2012

Re : un problème insoluble pour moi

Ma faute. Essaye ceci :

Code:

Sub Macro1()
    Dim NbLignes As Integer
    Dim Y As Integer
    Dim Compteur As Integer
    Dim Tableau() As Long
    
    ' On commence par trier la feuille selon les identifiants
    Cells.Select
    Selection.Sort Key1:=Range("D2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    ActiveWindow.SmallScroll Down:=-9
    
    ' On compte le nombre de lignes
    NbLignes = Cells(Rows.Count, 2).End(xlUp).Row
    
    For Y = 2 To NbLignes
        If Cells(Y, 4) = Cells(Y + 1, 4) And Cells(Y, 4) = Cells(Y + 2, 4) Then
            Cells(Y, 18) = Cells(Y, 18) & Cells(Y + 1, 18) & Cells(Y + 2, 18)
            Compteur = Compteur + 1
            ReDim Preserve Tableau(Compteur)
            Tableau(Compteur) = Y + 1
            Compteur = Compteur + 1
            ReDim Preserve Tableau(Compteur)
            Tableau(Compteur) = Y + 2
            Y = Y + 2
        End If
    
        If Cells(Y, 4) = Cells(Y + 1, 4) Then
            Cells(Y, 18) = Cells(Y, 18) & Cells(Y + 1, 18)
            Compteur = Compteur + 1
            ReDim Preserve Tableau(Compteur)
            Tableau(Compteur) = Y + 1
            Y = Y + 1
        End If
    Next Y

camarchepas · 19 Septembre 2012

Re : un problème insoluble pour moi

Bonjour,

Birac as tu regardés la proposition faite 4 paragraphes plus haut ?

https://www.excel-downloads.com/threads/un-probleme-insoluble-pour-moi.192202/

Car si tu lis la moitiés des réponses , forcement la prochaine fois tu n'auras plus de réponse

birac · 19 Septembre 2012

Re : un problème insoluble pour moi

Bonsoir

Autant pour moi, je n'ai compris qu'après qu'il me fallait rajouter une ligne dans le code pour gérer la colonne O.
Maintenant ca fonctionne correctement.

Puis je me permettre une autre question : si je devais, au lieu de mettre les H,M,P dans la même cellule, les avoir chacun dans une cellule différentes ? est ce faisable dans ce type de code ? (voir fichier joint ou le H de R2 reste en R2, le M du même identifiant remonte en T2 et le P du même remonte en V2 ??)

Merci

Philippe

Dormeur74 · 19 Septembre 2012

Re : un problème insoluble pour moi

Bonjour birac,

Bien sûr que c'est possible. On peut éviter la concaténation des lettres et les mettre dans des cellules différentes.

Mais je suis surpris que tu ne te sois pas penché sur le travail intéressant de camarchepas (qui m'a appris pas mal de choses) et que sa remarque de 14h40, que je trouve justifiée, soit restée sans suite.

Comme j'ai plus de soixante balais et un peu d'expérience, ça me gène de poursuivre sur ce fil. Je pense que tu comprendras.

birac · 20 Septembre 2012

Re : un problème insoluble pour moi

Dormeur74 à dit:
Bonjour birac,

Bien sûr que c'est possible. On peut éviter la concaténation des lettres et les mettre dans des cellules différentes.

Mais je suis surpris que tu ne te sois pas penché sur le travail intéressant de camarchepas (qui m'a appris pas mal de choses) et que sa remarque de 14h40, que je trouve justifiée, soit restée sans suite.

Comme j'ai plus de soixante balais et un peu d'expérience, ça me gène de poursuivre sur ce fil. Je pense que tu comprendras.

Bonjour

Je me suis penché sur son travail, mais après avoir posté ma première réponse. En effet, j'ai compris après (ce que je cite précédemment) que je pouvais intégrer une autre ligne afin de trier aussi ma colonne O. J'ai même tenté ensuite d'essayer de comprendre si, en partant de ce code, je pouvais moi même amener la récupération dans des cellules différentes, mais je n'ai pas réussi. Vous dites avoir plus de 60 ans, j'en ai pour ma part 50 et je n'ai jamais eu la possibilité d'approfondir mes connaissances en macro Excel et en VB - travail en grande quantité + engagement associatif professionnel qui me laisse peu de temps, c'est aussi pour cela que je demande de l'aide dans les forums

Cordialement

Philippe

birac · 20 Septembre 2012

Re : un problème insoluble pour moi

birac à dit:
Bonjour et merci à toi aussi

Celle-ci marche très bien, bien que je ne la comprenne pas totalement, mais bon, je suis encore un débutant en macro.

Juste une petite question : est il possible de rajouter dans cette macro, selon le même principe que la remontée des formation H,M,P, de remonter de la même manière les données de la colonne O ? (12.0X, etc)

Grand merci à toi et à toutes celles et tous ceux qui participent à ce forum pour aider les autres.

Cordialement

Philippe

Re bonjour,

Pour info, voici ce que j'avais répondu à camarchepas, en citant sa réponse, hier matin, à 9h16

Cordialement

Philippe

camarchepas · 20 Septembre 2012

Re : un problème insoluble pour moi

Bonjour Birac,

Un gros problème de dialogue je crois , Enfin ....

Code:

Code :
Sub CompletePremier()
Dim MonDico As Object
Dim LigneCourante As Long, LigneReference As Long
Dim Lecture As String

  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  LigneCourante = 2
  
  'Boucle de la 1° ligne de données à la derniére ligne non vide de la colonne B
  Do While LigneCourante <= Range("B" & Rows.Count).End(xlUp).Row
    Lecture = Cells(LigneCourante, "D")
    
    'Si élément non connu ajout au dico et mémorise numéro de ligne, puis passe à la ligne suivante
    If Not MonDico.Exists(Lecture) Then
      MonDico(Lecture) = LigneCourante
      LigneCourante = LigneCourante + 1
      
     'Si élément connu dans dico alors lecture de la mémoire de ligne, concatene la colonne R puis efface la ligne courante
    Else
      LigneReference = MonDico(Lecture)

'Modif pour l'affichage de la colonne O cumulé dans la colonne R

     Range("R" & LigneReference) = Range("R" & LigneReference) & "," & Range("R" & LigneCourante)& ":" & Range("O" & LigneCourante)

      Rows(LigneCourante).EntireRow.Delete
    End If
  Loop
    
  Application.ScreenUpdating = True
End Sub

birac · 20 Septembre 2012

Re : un problème insoluble pour moi

camarchepas à dit:

Bonjour Birac,

Un gros problème de dialogue je crois , Enfin ....

Code:

Code :
Sub CompletePremier()
Dim MonDico As Object
Dim LigneCourante As Long, LigneReference As Long
Dim Lecture As String

  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  LigneCourante = 2
  
  'Boucle de la 1° ligne de données à la derniére ligne non vide de la colonne B
  Do While LigneCourante <= Range("B" & Rows.Count).End(xlUp).Row
    Lecture = Cells(LigneCourante, "D")
    
    'Si élément non connu ajout au dico et mémorise numéro de ligne, puis passe à la ligne suivante
    If Not MonDico.Exists(Lecture) Then
      MonDico(Lecture) = LigneCourante
      LigneCourante = LigneCourante + 1
      
     'Si élément connu dans dico alors lecture de la mémoire de ligne, concatene la colonne R puis efface la ligne courante
    Else
      LigneReference = MonDico(Lecture)

'Modif pour l'affichage de la colonne O cumulé dans la colonne R

     Range("R" & LigneReference) = Range("R" & LigneReference) & "," & Range("R" & LigneCourante)& ":" & Range("O" & LigneCourante)

      Rows(LigneCourante).EntireRow.Delete
    End If
  Loop
    
  Application.ScreenUpdating = True
End Sub

Bonjour et merci pour ce code qui correspond à peu près à ce que je cherche. sachant que j'arrive maintenant à avoir la formation et les cas réalisé.
Je reformule ma seconde demande, bien évidemment si cela est possible sans être trop compliqué :
Peut on reporter les données, avant suppression des lignes de doublons identifiants, sur différentes cellules de la ligne première comme ceci :
Formation H à laisser dans la colonne R - cas concernant la formation H dans la colonne S
Formation M à reporter dans la colonne T - cas concernant la formation M dans la colonne U
Formation P à reporter dans la colonne V - cas concernant la formation P dans la colonne W

Si le code arrive à faire ceci, je pourrais alors filtrer en fonction des formations et des cas pour envoyer un mailing de rappel

Merci d'avance

Philippe

camarchepas · 20 Septembre 2012

Re : un problème insoluble pour moi

Bonsoir ,

Allez , encore un ptit effort et hop :

Code:

Sub CompletePremier()
Dim MonDico As Object
Dim LigneCourante As Long, LigneReference As Long
Dim Lecture As String

  Set MonDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  LigneCourante = 2
 
  'Boucle de la 1° ligne de données à la derniére ligne non vide de la colonne B
  Do While LigneCourante <= Range("B" & Rows.Count).End(xlUp).Row
    Lecture = Cells(LigneCourante, "D")
   
    'Si élément non connu ajout au dico et mémorise numéro de ligne, puis passe à la ligne suivante
    If Not MonDico.Exists(Lecture) Then
      MonDico(Lecture) = LigneCourante
      LigneCourante = LigneCourante + 1
     
     'Si élément connu dans dico alors lecture de la mémoire de ligne, concatene la colonne R puis efface la ligne courante
    Else
      LigneReference = MonDico(Lecture)

'Modif de stockage

'Formation H à laisser dans la colonne R - cas concernant la formation H dans la colonne S
'Formation M à reporter dans la colonne T - cas concernant la formation M dans la colonne U
'Formation P à reporter dans la colonne V - cas concernant la formation P dans la colonne W

select case Range("R" & LigneCourante)

case "H" :    Range("R" & LigneReference) =  Range("R" & LigneCourante)
                 Range("S" & LigneReference) =  Range("O" & LigneCourante)

case "M" :    Range("T" & LigneReference) =  Range("R" & LigneCourante)
                 Range("U" & LigneReference) =  Range("O" & LigneCourante)

case "P" :    Range("V" & LigneReference) =  Range("R" & LigneCourante)
                 Range("W" & LigneReference) =  Range("O" & LigneCourante)

end select

      Rows(LigneCourante).EntireRow.Delete
    End If
  Loop
   
  Application.ScreenUpdating = True
End Sub

Effectuez une recherche sur Excel Downloads...

un problème insoluble pour moi

birac

XLDnaute Junior

Pièces jointes

Dormeur74

XLDnaute Occasionnel

Dormeur74

XLDnaute Occasionnel

camarchepas

XLDnaute Barbatruc

birac

XLDnaute Junior

birac

XLDnaute Junior

Pièces jointes

Dormeur74

XLDnaute Occasionnel

camarchepas

XLDnaute Barbatruc

birac

XLDnaute Junior

Pièces jointes

Dormeur74

XLDnaute Occasionnel

birac

XLDnaute Junior

birac

XLDnaute Junior

camarchepas

XLDnaute Barbatruc

birac

XLDnaute Junior

camarchepas

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums