Trier des lignes par groupes inégaux
Bonjour je suis nouveau sur ce forum. Je sais que sur ce forum on a déjà discuté d'un problème similaire.
Voici donc mon problème. Je télécharge une liste d'entreprises d'un site web. Le format est celui ci.
Colonne B les noms des entreprises, Colonne C les adresses, no de téléphone, nom du propriétaire, type d'entreprise etc.
Pour chaque entreprise le nombre de lignes différent. Voir le fichier joint.
Dans la colonne A j'ai codifié les Cies de 1 à 4.
J'aimerais pouvoir trier les compagnie par ordre croissant de code (Colonne A)
Merci à l'avance de vos réponses
Note sans être un expert je me débrouille assez bien avec VBA
Bonjour Cotecour,
je te retourne ton fichier modifié :
* à l'ouverture du fichier, tu es sur "Feuil3" ; tu peux voir qu'elle est inchangée
* j'ai ajouté une feuille, que j'ai nommé "Feuil4" ; sélectionne cette feuille
* tu peux voir qu'il y a seulement les 2 premières lignes de ton tableau initial
* Ctrl e ➯ tri effectué ; vérifie tout soigneusement (y compris les 4 liens)
si besoin, tu peux demander une adaptation.
merci de me dire si ça te convient.
dhany
Bonjour,
http://boisgontierjacques.free.fr/fichiers/Cellules/TriGroupes.xlsm
Sub TriGroupes()
Application.ScreenUpdating = False
ligneDéb = 3
NoBordure
NbCol = 3
Columns("A:A").Offset(0, NbCol).Insert Shift:=xlToRight
i = ligneDéb
Do While i <= [A65000].End(xlUp).Row + 1
temp = Cells(i, 1)
temp2 = Cells(i, 1)
Cells(i, 1).Offset(0, NbCol) = temp2
i = i + 1
Do While Cells(i, 1) = "" And i <= [C65000].End(xlUp).Row
Cells(i, 1).Offset(0, NbCol) = temp2
i = i + 1
Loop
Loop
Range(Cells(ligneDéb, 1), Cells([C65000].End(xlUp).Row, NbCol + 1)).Sort Key1:=Cells(ligneDéb, 1).Offset(, NbCol), Order1:=xlAscending, Header:=xlNo
[A:A].Offset(0, NbCol).Delete Shift:=xlToLeft
Bordures ligneDéb, NbCol
End Sub
Sub NoBordure()
With Cells
.Borders(xlDiagonalDown).LineStyle = xlNone
.Borders(xlDiagonalUp).LineStyle = xlNone
.Borders(xlEdgeLeft).LineStyle = xlNone
.Borders(xlEdgeTop).LineStyle = xlNone
.Borders(xlEdgeBottom).LineStyle = xlNone
.Borders(xlEdgeRight).LineStyle = xlNone
.Borders(xlInsideVertical).LineStyle = xlNone
.Borders(xlInsideHorizontal).LineStyle = xlNone
End With
End Sub
Sub Bordures(ligneDéb, NbCol)
Set suiv1 = Cells(ligneDéb, 1)
Do While Not témoin
Set suiv2 = suiv1.End(xlDown)
If suiv2.Row = 1048576 Then Set suiv2 = [C65000].End(xlUp).Offset(1): témoin = True
Range(suiv1, suiv2.Offset(-1, NbCol - 1)).BorderAround Weight:=xlThin
Set suiv1 = suiv2
Loop
End Sub
Ceuzin
Bonsoir Cotecour, ceuzin,
je t'avais proposé une solution dans mon post précédent du 13 juillet à 02:22 ; n'en tiens plus compte, car ceuzin a bien raison : c'est possible de faire ce travail sans ajouter une nouvelle feuille ; bravo ceuzin !
j'ai repris son idée, mais sans ajouter de colonne supplémentaire (qu'il a supprimé ensuite) ; ce qui donne ce nouveau fichier :
Ctrl e ➯ travail effectué !
Alt F11 pour voir le code VBA, puis revenir sur Excel
si besoin, tu peux demander une adaptation.
merci de me dire si ça te convient.
Salut Cotecour,
après avoir épluché le code de ceuzin (merci ceuzin!), voici de quoi trier tes sociétés par code et par ordre alphabétique.
Un double-clic en [A1] démarre la macro.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tExtract()
Cancel = True
'
If Not Intersect(Target, Range("A1")) Is Nothing Then
Application.ScreenUpdating = False
'
Cells.Borders.LineStyle = xlNone
Cells.Interior.Color = xlNone
tData = Range("A3:B" & Range("C" & Rows.Count).End(xlUp).Row)
ReDim tExtract(UBound(tData, 1))
'
For x = 1 To UBound(tData, 1)
If tData(x, 1) <> "" Then sFlag = CStr(tData(x, 1)) & CStr(tData(x, 2))
tExtract(x - 1) = sFlag
Next
'
Range("D3").Resize(UBound(tData, 1), 1).Value = WorksheetFunction.Transpose(tExtract)
Range("A3:D" & Range("D" & Rows.Count).End(xlUp).Row).Sort Key1:=Range("D4"), Order1:=xlAscending, Orientation:=xlTopToBottom
Columns(4).ClearContents
'
For x = 4 To Range("C" & Rows.Count).End(xlUp).Row
If Range("A" & x).Value <> "" Or x = Range("C" & Rows.Count).End(xlUp).Row Then
Range("A" & IIf(iFlag = 0, 3, iFlag) & ":C" & x - IIf(x < Range("C" & Rows.Count).End(xlUp).Row, 1, 0)).BorderAround Weight:=xlThin
Range("A" & IIf(iFlag = 0, 3, iFlag) & ":C" & IIf(iFlag = 0, 3, iFlag)).BorderAround Weight:=xlThin
Range("A" & IIf(iFlag = 0, 3, iFlag) & ":C" & IIf(iFlag = 0, 3, iFlag)).Interior.Color = RGB(215, 215, 215)
iFlag = x
End If
Next
'
Application.ScreenUpdating = True
End If
'
End Sub
Maintenant, je vais me casser la tête pour comprendre la technique de Dhany...
A+
bonjour
salut dhany
avec "mettre sous forme de tableau" menu n°1 d'Excel, à savoir par coeur
et menu données Obtenir à partir de plage
ensuite il faut 30 secondes
pas de VBA, aucun calcul !
tu réactualises quand nécessaire, Power Query a gardé la méthode
bon dimanche
Salut tout le monde,
petite correction de la fin de mon code concernant l'encadrement après tri.
...
Range("A3:C" & Range("C" & Rows.Count).End(xlUp).Row).BorderAround Weight:=xlThin
For x = 3 To Range("C" & Rows.Count).End(xlUp).Row
If Range("A" & x).Value <> "" Then
Range("A" & x & ":C" & x).BorderAround Weight:=xlThin
Range("A" & x & ":C" & x).Interior.Color = RGB(215, 215, 215)
End If
Next
...
A+