regrouper certaines données sous conditions

Le
jip
Bonjour
Dans un tableau excel 2010, j'ai une structure sous cette forme

100_1 109J 1
100_1 109J 11-13
100_1 109J 3
100_1 109J 7-8
100_1 112J 1
100_1 113J 1-2
100_2 123J 2
100_2 131J 26-39
100_2 131J 36
100_2 131J 46-64
100_2 131J 70-73
100_3 131J 75-76
100_3 131J 78
100_3 131J 80
100_3 135J 10-13
100_3 137J 2
100_3 141J 9-11
100_3 148J 2

Je souhaiterais pour chaque type de données dans la colonne A, regrouper =
les données de la colonne B dans une seule cellule, en les séparant par=
des " ;".
Soit
100_1 109J 1 ; 109J 11-13 ; 109J 3 ; () ; 113J 1-2
100_2 123J 2 ; 131J 26-39 ; () ; 131J 70-73
etc

Avec les formules je ne m'en sors pas
Merci d'avance.
Vidéos High-Tech et Jeu Vidéo
Téléchargements
Vos réponses
Gagnez chaque mois un abonnement Premium avec GNT : Inscrivez-vous !
Trier par : date / pertinence
MichD
Le #26368674
Bonjour,

Essaie quelque chose comme ceci :

J'ai supposé que tes données dans ton tableau sont présentées en ordre croissant
comme dans ton exemple!

'--------------------------------------------------------------------------
Sub test()

Dim DerLig As Long, A As Long, X As String
Dim S As String, Compteur As Long, Rg As Range

'Adapte le nom de la "Feuil1" selon le nom de l'onglet
'où se retrouvent les données
With Worksheets("Feuil1")
DerLig = .Range("A" & .Rows.Count).End(xlUp).Row

'Si tes données débutent à une autre ligne que A1
'modifie A1 dans la ligne suivante pour l'adresse
'de la cellule où débutent les données
Set Rg = .Range("A1:A" & DerLig)
End With

'La copie des données se fera à partir de la première
'ligne des données.
For A = 1 To Rg.Rows.Count
Compteur = Compteur + 1
X = Split(Rg(A), " ")(0)
Do While InStr(1, Rg(A), X, vbTextCompare) > 0
S = S & Rg(A) & ";"
A = A + 1
Loop
If S <> "" Then
S = Left(S, Len(S) - 1)
Rg(1, 1).Offset(Compteur - 1, 1) = S
S = ""
End If
A = A - 1
Next
Rg(1, 1).Offset(, 1).EntireColumn.AutoFit
End Sub
'--------------------------------------------------------------------------
MichD
Le #26368673
Celle-ci est mieux adaptée si tu as beaucoup de données.
C'est quasiment la même chose!

'---------------------------------------------------------------------------
Sub test()

Dim DerLig As Long, A As Long, X As String
Dim S As String, Compteur As Long, Rg As Range

Application.ScreenUpdating = False
Application.EnableEvents = False

'Adapte le nom de la "Feuil1" selon le nom de l'onglet
'où se retrouvent les données
With Worksheets("Feuil1")
DerLig = .Range("A" & .Rows.Count).End(xlUp).Row

'Si tes données débutent à une autre ligne que A1
'modifie A1 dans la ligne suivante pour l'adresse
'de la cellule où débutent les données
Set Rg = .Range("A1:A" & DerLig)
End With

'La copie des données se fera à partir de la première
'ligne des données.
For A = 1 To Rg.Rows.Count
Compteur = Compteur + 1
X = Split(Rg(A), " ")(0)
Do While InStr(1, Rg(A), X, vbTextCompare) > 0
S = S & Rg(A) & ";"
A = A + 1
Loop
If S <> "" Then
S = Left(S, Len(S) - 1)
Rg(1, 1).Offset(Compteur - 1, 1) = S
S = ""
End If
A = A - 1
Next
Rg(1, 1).Offset(, 1).EntireColumn.AutoFit

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'---------------------------------------------------------------------------
jip
Le #26368683
Le jeudi 24 septembre 2015 15:52:47 UTC+2, MichD a écrit :
Bonjour,

Essaie quelque chose comme ceci :

J'ai supposé que tes données dans ton tableau sont présentées en ordre croissant
comme dans ton exemple!

'------------------------------------------------------------------------ --
Sub test()

Dim DerLig As Long, A As Long, X As String
Dim S As String, Compteur As Long, Rg As Range

'Adapte le nom de la "Feuil1" selon le nom de l'onglet
'où se retrouvent les données
With Worksheets("Feuil1")
DerLig = .Range("A" & .Rows.Count).End(xlUp).Row

'Si tes données débutent à une autre ligne que A1
'modifie A1 dans la ligne suivante pour l'adresse
'de la cellule où débutent les données
Set Rg = .Range("A1:A" & DerLig)
End With

'La copie des données se fera à partir de la première
'ligne des données.
For A = 1 To Rg.Rows.Count
Compteur = Compteur + 1
X = Split(Rg(A), " ")(0)
Do While InStr(1, Rg(A), X, vbTextCompare) > 0
S = S & Rg(A) & ";"
A = A + 1
Loop
If S <> "" Then
S = Left(S, Len(S) - 1)
Rg(1, 1).Offset(Compteur - 1, 1) = S
S = ""
End If
A = A - 1
Next
Rg(1, 1).Offset(, 1).EntireColumn.AutoFit
End Sub
'------------------------------------------------------------------------ --



Bonjour et merci.
Le résultat est presque correct puisque j'obtiens :
100_1 100_1;100_1;100_1;100_1;100_1;100_1
100_1 100_2;100_2;100_2;100_2;100_2
etc
les données à regrouper sont en colonne B, que modifier ?
Merci encore
MichD
Le #26368682
Si tes données sont en colonne B, le résultat s'affichera en colonne C
et débuteront à la première ligne des données en colonne B.

'------------------------------------------------------------------
Sub test()

Dim DerLig As Long, A As Long, X As String
Dim S As String, Compteur As Long, Rg As Range

Application.ScreenUpdating = False
Application.EnableEvents = False

'Adapte le nom de la "Feuil1" selon le nom de l'onglet
'où se retrouvent les données
With Worksheets("Feuil1")
DerLig = .Range("B" & .Rows.Count).End(xlUp).Row

'Si tes données débutent à une autre ligne que B1
'modifie b1 dans la ligne suivante pour l'adresse
'de la cellule où débutent les données
Set Rg = .Range("B1:B" & DerLig)
End With

'La copie des données se fera à partir de la première
'ligne des données.
For A = 1 To Rg.Rows.Count
Compteur = Compteur + 1
X = Split(Rg(A), " ")(0)
Do While InStr(1, Rg(A), X, vbTextCompare) > 0
S = S & Rg(A) & ";"
A = A + 1
Loop
If S <> "" Then
S = Left(S, Len(S) - 1)
Rg(1, 1).Offset(Compteur - 1, 1) = S
S = ""
End If
A = A - 1
Next
Rg(1, 1).Offset(, 1).EntireColumn.AutoFit

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'------------------------------------------------------------------
jip
Le #26368685
Le jeudi 24 septembre 2015 16:22:50 UTC+2, MichD a écrit :
Si tes données sont en colonne B, le résultat s'affichera en colonne C
et débuteront à la première ligne des données en colonne B.



Exact
Mais ça fonctionne partiellement car je n'ai pas tout
Et je n'ai plus de repère des lignes
http://www.cjoint.com/c/EIyoR7tKA0z
MichD
Le #26368733
Je n'avais pas saisi la disposition de tes données...

Fais un copier-coller de la procédure suivante à la place de l'autre
et cela devrait fonctionner.

'-------------------------------------------------------
Sub test()

Dim DerLig As Long, A As Long, X As String
Dim S As String, Compteur As Long, Rg As Range

Application.ScreenUpdating = False
Application.EnableEvents = False


'Adapte le nom de la "Feuil1" selon le nom de l'onglet
'où se retrouvent les données
With Worksheets("Feuil1")
DerLig = .Range("A" & .Rows.Count).End(xlUp).Row

'Si tes données débutent à une autre ligne que A1
'modifie A1 dans la ligne suivante pour l'adresse
'de la cellule où débutent les données
Set Rg = .Range("A1:A" & DerLig)
End With

'La copie des données se fera à partir de la première
'ligne des données.
For A = 1 To Rg.Rows.Count
Compteur = Compteur + 1
X = Rg(A)
Do While InStr(1, Rg(A), X, vbTextCompare) > 0
S = S & Rg(A).Offset(, 1) & ";"
A = A + 1
Loop
If S <> "" Then
S = Left(S, Len(S) - 1)
Rg(Compteur, 1).Offset(, 2) = S
S = ""
End If
A = A - 1
Next
Rg(1, 1).Offset(, 1).EntireColumn.AutoFit

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub
'-------------------------------------------------------
jip
Le #26368749
Le jeudi 24 septembre 2015 23:12:53 UTC+2, MichD a écrit :
Je n'avais pas saisi la disposition de tes données...

Fais un copier-coller de la procédure suivante à la place de l'autre
et cela devrait fonctionner.



Oui effectivement ça fonctionne maintenant.
Merci beaucoup...que de temps gagné.
Publicité
Poster une réponse
Anonyme