XL 2019 Tri d'un tableau en vba

[netparty]

Bonjour à tous

Je cherche le moyen de trier mon tableau, certaine ligne comporte des valeurs en V et W et j'aimerais que cette ligne soit dupliquée juste en dessous et que la valeur dans W soie placée en V de la ligne dupliquée.

Je joint un fichier cela sera plus clair car j'y ai placé un exemple.

Merci d'avance

bonne journée

 

[Phil69970]

Bonjour @netparty

Je te propose ce fichier

*Merci de ton retour

@Phil69970

 

[job75]

Bonsoir netparty, Phil69970,

Si le tableau est grand pour aller vite il faut travailler sur des tableaux VBA.

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim col%, ncol%, tablo, resu(), i&, n&, j%
col = 23 'colonne W
With Sheets("Feuil2").[A1].CurrentRegion
    ncol = IIf(.Columns.Count < col, col, .Columns.Count)
    tablo = .Resize(, ncol) 'matrice, plus rapide
    ReDim resu(1 To UBound(tablo) + Application.CountA(.Columns(col).Offset(1)), 1 To ncol - 1)
End With
For i = 1 To UBound(tablo)
    n = n + 1
    For j = 1 To ncol
        resu(n, j + (j > col)) = tablo(i, j) 'décalage APRES W (True => -1)
    Next j
    If n = 1 Then resu(n, col - 1) = "ADRESSE"
    If tablo(i, col) <> "" And n > 1 Then
        n = n + 1
        For j = 1 To ncol
            resu(n, j + (j >= col)) = tablo(i, j) 'décalage A PARTIR de W
        Next j
    End If
Next i
'---restitution---
Application.ScreenUpdating = False
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1] '1ère cellule de restitution
    .Resize(n, ncol - 1) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol - 1).ClearContents 'RAZ en dessous
End With
Columns.AutoFit 'ajustement largeurs
Cells.HorizontalAlignment = xlCenter 'centrage
End Sub

Elle se déclenche quand on active la feuille.

Edit : j'ai testé en recopiant le tableau A2:X25 sur 12 000 lignes (seulement).

Chez moi cette macro s'exécute en 0,5 seconde.

La macro du poste #2 s'exécute en 15 secondes.

Bonne nuit.

 

[netparty]

Bonjour @netparty

Je te propose ce fichier

*Merci de ton retour

@Phil69970

Bonjour @Phil69970

Merci pour ton fichier il fonctionne très bien mais si j'ai des colonne après X elle ne sont pas copiées

Bonne journée

 

[netparty]

Bonsoir netparty, Phil69970,

Si le tableau est grand pour aller vite il faut travailler sur des tableaux VBA.

Voyez le fichier joint et cette macro dans le code de la feuille "Résultat" :

Private Sub Worksheet_Activate()
Dim col%, ncol%, tablo, resu(), i&, n&, j%
col = 23 'colonne W
With Sheets("Feuil2").[A1].CurrentRegion
    ncol = IIf(.Columns.Count < col, col, .Columns.Count)
    tablo = .Resize(, ncol) 'matrice, plus rapide
    ReDim resu(1 To UBound(tablo) + Application.CountA(.Columns(col).Offset(1)), 1 To ncol - 1)
End With
For i = 1 To UBound(tablo)
    n = n + 1
    For j = 1 To ncol
        resu(n, j + (j > col)) = tablo(i, j) 'décalage APRES W (True => -1)
    Next j
    If n = 1 Then resu(n, col - 1) = "ADRESSE"
    If tablo(i, col) <> "" And n > 1 Then
        n = n + 1
        For j = 1 To ncol
            resu(n, j + (j >= col)) = tablo(i, j) 'décalage A PARTIR de W
        Next j
    End If
Next i
'---restitution---
If FilterMode Then ShowAllData 'si la feuille est filtrée
With [A1] '1ère cellule de restitution
    .Resize(n, ncol - 1) = resu
    .Offset(n).Resize(Rows.Count - n - .Row + 1, ncol - 1).ClearContents 'RAZ en dessous
End With
Columns.AutoFit 'ajustement largeurs
Cells.HorizontalAlignment = xlCenter 'centrage
End Sub

Elle se déclenche quand on active la feuille.

Edit : j'ai testé en recopiant le tableau A2:X25 sur 12 000 lignes (seulement).

Chez moi cette macro s'exécute en 0,5 seconde.

La macro du poste #2 s'exécute en 15 secondes.

Bonne nuit.

Bonjour @job75

Merci pour ton aide ton fichier fonctionne nickel

Bonne journée

 

[job75]

Bonjour netparty,

Je viens de faire des modification sur la macro du post #3, prenez le bon fichier.

A+

 

[netparty]

Bonjour netparty,

Je viens de faire des modification sur la macro du post #3, prenez le bon fichier.

A+

Merci @job75

Top

Bonne journée

 

[Phil69970]

Bonjour à tous

@netparty

Voici le fichier modifié pour n'importe quelle colonne supplémentaire

Merci pour ton fichier il fonctionne très bien mais si j'ai des colonne après X elle ne sont pas copiées

*Merci de ton retour

@Phil69970

 

[netparty]

Bonjour à tous

@netparty

Voici le fichier modifié pour n'importe quelle colonne supplémentaire


*Merci de ton retour

@Phil69970

Merci