Logo GNT
Actualités Tests & Guides Bons Plans
Twitter iPhone pliant OnePlus 11 PS5 Disney+ Orange Livebox Windows 11
Entraide Applications Microsoft Office Excel Récupérer une liste...

Récupérer une liste...

5 réponses
Avatar
Jero
Bonjour à tous,
J'expose mon "problème"
Voilà ce que j'ai... (colonnes de A à D)
Noms Projet1 Projet2 Projet3

N1 P1 PP1 PPP1

N1 P2

N1 P3

N1 P4 PP4

N2 P5 PP1

N2 P6 PP6 PPP1

N3 P7 PP7 PPP2

N4 P8 PP1

N4 P9 PPP3

N1 P0 PP10



=> ce que je souhaite obtenir.





NomsRécupérés TousLesProjets

N1 P1-P2-P3-P4-P0-PP1-PP4-PP10-PPP1

N2 P5-P6-PP1-PP6-PPP1

N3 P7-PP7-PPP2

N4 P8-P9-PPP3



Notes :

1 - je sais déjà comment récupérer la liste des noms (colonne NomsRécupérés)
avec une Sub que j'ai écrite. ou que j'ai trouvé quelque part (?) - voir
ci-dessous

2 - la colonne TousLesProjets est en fait une concaténation des colonnes
Projet1, Projet2, Projet3

3 - si qq1 à déjà bossé la-dessus, ç me ferait gagner du temps...



La sub :

Sub CollerListe(Tri As Boolean, CelluleDestination, PlageSource)
Dim cl As Integer, lg_deb As Integer, nm, msg
Dim rg As Range, diff As Boolean, nbc As Integer, cell, cellule
Dim lg As Long
Application.Goto Reference:=Range(CelluleDestination)
ActiveCell.Offset(0, 0).Activate
cl = ActiveCell.Column
lg_deb = ActiveCell.Row
Set rg = Range(CelluleDestination)
For Each cell In Range(PlageSource)
nm = cell.Value
diff = True
For Each cellule In rg
If cellule.Value = nm Then
diff = False
Exit For
End If
Next cellule
If diff Then
ActiveCell.Value = nm

nbc = nbc + 1
ActiveCell.Offset(1, 0).Activate
lg = ActiveCell.Row
Set rg = Range(Cells(lg_deb, cl), Cells(lg, cl))
End If
'coller la ligne

Next cell
If Tri = True Then
Set rg = Range(Cells(lg_deb, cl), Cells(lg - 1, cl))
rg.Select
Selection.Sort Key1:=Range(CelluleDestination), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End If
msg = nbc & "cellules collées"
MsgBox msg, vbOKOnly, " "
End Sub



D'avance merci,

Jero
Signaler un problème avec ce contenu

5 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
Daniel
Bonjour.
La macro suivante affiche les résultats sur une nouvelle feuille :

Sub test()
Dim Tablo(), c As Range, Plage As Range, Flag As Boolean
Dim Ligne As Long
Ligne = Range("A65536").End(xlUp).Row
ReDim Tablo(Ligne, 1)
Set Plage = Range("A1", Range("A65536").End(xlUp))
For Each c In Plage
Flag = False
For i = 0 To Ligne
If c.Value = Tablo(i, 0) Then
Flag = True
Tablo(i, 1) = Tablo(i, 1) & c.Offset(0, 1).Value & _
c.Offset(0, 2).Value & c.Offset(0, 3).Value
End If
Next i
If Flag = False Then
For i = 0 To Ligne
If Tablo(i, 0) = "" Then
Tablo(i, 0) = c.Value
Tablo(i, 1) = Tablo(i, 1) & c.Offset(0, 1).Value & _
c.Offset(0, 2).Value & c.Offset(0, 3).Value
Exit For
End If
Next i
End If
Next c
Sheets.Add
Range("A1").Select
For i = 0 To Ligne
ActiveCell.Offset(i, 0).Value = Tablo(i, 0)
ActiveCell.Offset(i, 1).Value = Tablo(i, 1)
ActiveCell.Offset(1, 0).Select
Next i
End Sub

Cordialement.
Daniel
"Jero" <~ a écrit dans le message de news:

Bonjour à tous,
J'expose mon "problème"
Voilà ce que j'ai... (colonnes de A à D)
Noms Projet1 Projet2 Projet3

N1 P1 PP1 PPP1

N1 P2

N1 P3

N1 P4 PP4

N2 P5 PP1

N2 P6 PP6 PPP1

N3 P7 PP7 PPP2

N4 P8 PP1

N4 P9 PPP3

N1 P0 PP10



=> ce que je souhaite obtenir.





NomsRécupérés TousLesProjets

N1 P1-P2-P3-P4-P0-PP1-PP4-PP10-PPP1

N2 P5-P6-PP1-PP6-PPP1

N3 P7-PP7-PPP2

N4 P8-P9-PPP3



Notes :

1 - je sais déjà comment récupérer la liste des noms (colonne
NomsRécupérés) avec une Sub que j'ai écrite. ou que j'ai trouvé quelque
part (?) - voir ci-dessous

2 - la colonne TousLesProjets est en fait une concaténation des colonnes
Projet1, Projet2, Projet3

3 - si qq1 à déjà bossé la-dessus, ç me ferait gagner du temps...



La sub :

Sub CollerListe(Tri As Boolean, CelluleDestination, PlageSource)
Dim cl As Integer, lg_deb As Integer, nm, msg
Dim rg As Range, diff As Boolean, nbc As Integer, cell, cellule
Dim lg As Long
Application.Goto Reference:=Range(CelluleDestination)
ActiveCell.Offset(0, 0).Activate
cl = ActiveCell.Column
lg_deb = ActiveCell.Row
Set rg = Range(CelluleDestination)
For Each cell In Range(PlageSource)
nm = cell.Value
diff = True
For Each cellule In rg
If cellule.Value = nm Then
diff = False
Exit For
End If
Next cellule
If diff Then
ActiveCell.Value = nm

nbc = nbc + 1
ActiveCell.Offset(1, 0).Activate
lg = ActiveCell.Row
Set rg = Range(Cells(lg_deb, cl), Cells(lg, cl))
End If
'coller la ligne

Next cell
If Tri = True Then
Set rg = Range(Cells(lg_deb, cl), Cells(lg - 1, cl))
rg.Select
Selection.Sort Key1:=Range(CelluleDestination), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom
End If
msg = nbc & "cellules collées"
MsgBox msg, vbOKOnly, " "
End Sub



D'avance merci,

Jero




Avatar
Ardus Petus
Bonjour Jero

Voilà ce que j'ai pondu.
Ca te convient?

Cordialement
--
AP

'--------------------------------------------
Sub Projets()

Const colTableau = "A"
Const colProjets = "B"
Const nbProjets = 3
Const colNomsUniques = "F"
Const colTousLesProjets = "G"

Dim rNom As Range
Dim rProjet As Range
Dim strProjets As String
Dim numP As Byte
Dim colP As Range
Dim derLigne As Long

'Détermination de la dernière ligne du tableau
derLigne = Cells(Rows.Count, colTableau).End(xlUp).Row

'Elimination des doublons de noms -> colNomsUniques
Range( _
Cells(1, colTableau), _
Cells(derLigne, colTableau) _
).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:Îlls(1, colNomsUniques), _
Unique:=True
'Boucle sur les noms dédoublonnés
For Each rNom In Range( _
Cells(2, colNomsUniques), _
Cells(Rows.Count, colNomsUniques).End(xlUp))

' Init chaîne résultante
strProjets = ""
'Boucle sur les colonnes Projet du tableau
For numP = 0 To nbProjets - 1
Set colP = Range( _
Cells(2, colProjets), _
Cells(derLigne, colProjets) _
).Offset(, numP)
'Boucle sur les lignes du tableau
For Each rProjet In colP
'si la ligne courante correspond au nom
If rNom.Value = _
Cells(rProjet.Row, colTableau).Value _
Then

'si le projet n'est pas vide, on l'ajoute à la chaîne
If rProjet.Text <> "" Then
strProjets = _
strProjets & rProjet.Text & "-"
End If
End If
Next rProjet
Next numP
' On enlève le dernier -
If Len(strProjets) > 0 Then strProjets = _
Left(strProjets, Len(strProjets) - 1)
'On Positionne le résultat
Cells(rNom.Row, colTousLesProjets).Value = strProjets
Next rNom
End Sub
Avatar
Daniel
'Détermination de la dernière ligne du tableau
derLigne = Cells(Rows.Count, colTableau).End(xlUp).Row


Bonjour.
T'as de la suite dans les idées, c'est bien... ;-))
Daniel

Avatar
Ardus Petus
J'ai bossé comme un malade (boulot de con) sur un bug comme ça dans une
série d'applis!

Pas envie de recommencer

--
AP

"Daniel" a écrit dans le message de
news:
'Détermination de la dernière ligne du tableau
derLigne = Cells(Rows.Count, colTableau).End(xlUp).Row


Bonjour.
T'as de la suite dans les idées, c'est bien... ;-))
Daniel





Avatar
Jero
Merci à vous (je n'ose dire les garçons en ce jour de la femme)
Je m'en vais de ce pas tester et vous tiens au courant...

Jero
"Jero" <~ a écrit dans le message de news:

Bonjour à tous,
J'expose mon "problème"
Voilà ce que j'ai... (colonnes de A à D)
Noms Projet1 Projet2 Projet3

N1 P1 PP1 PPP1

N1 P2

N1 P3

N1 P4 PP4

N2 P5 PP1

N2 P6 PP6 PPP1

N3 P7 PP7 PPP2

N4 P8 PP1

N4 P9 PPP3

N1 P0 PP10



=> ce que je souhaite obtenir.





NomsRécupérés TousLesProjets

N1 P1-P2-P3-P4-P0-PP1-PP4-PP10-PPP1

N2 P5-P6-PP1-PP6-PPP1

N3 P7-PP7-PPP2

N4 P8-P9-PPP3



Notes :

1 - je sais déjà comment récupérer la liste des noms (colonne
NomsRécupérés) avec une Sub que j'ai écrite. ou que j'ai trouvé quelque
part (?) - voir ci-dessous

2 - la colonne TousLesProjets est en fait une concaténation des colonnes
Projet1, Projet2, Projet3

3 - si qq1 à déjà bossé la-dessus, ç me ferait gagner du temps...



La sub :

Sub CollerListe(Tri As Boolean, CelluleDestination, PlageSource)
Dim cl As Integer, lg_deb As Integer, nm, msg
Dim rg As Range, diff As Boolean, nbc As Integer, cell, cellule
Dim lg As Long
Application.Goto Reference:=Range(CelluleDestination)
ActiveCell.Offset(0, 0).Activate
cl = ActiveCell.Column
lg_deb = ActiveCell.Row
Set rg = Range(CelluleDestination)
For Each cell In Range(PlageSource)
nm = cell.Value
diff = True
For Each cellule In rg
If cellule.Value = nm Then
diff = False
Exit For
End If
Next cellule
If diff Then
ActiveCell.Value = nm

nbc = nbc + 1
ActiveCell.Offset(1, 0).Activate
lg = ActiveCell.Row
Set rg = Range(Cells(lg_deb, cl), Cells(lg, cl))
End If
'coller la ligne

Next cell
If Tri = True Then
Set rg = Range(Cells(lg_deb, cl), Cells(lg - 1, cl))
rg.Select
Selection.Sort Key1:=Range(CelluleDestination), Order1:=xlAscending,
Header:=xlGuess, _
OrderCustom:=1, MatchCase:úlse, Orientation:=xlTopToBottom
End If
msg = nbc & "cellules collées"
MsgBox msg, vbOKOnly, " "
End Sub



D'avance merci,

Jero