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

5trigroupes.xlsm (22.11 Ko)

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.

dhany h-animaux37

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+

Rechercher des sujets similaires à "trier lignes groupes inegaux"