Tableau a classer en VBA

Bonjour

même si le titre semble simple, même les IA n'ont pas su m'aider. J'ai un tableau prevu pour plus de 22000 lignes et qui va de A a DA. Le classement se fait a partir de la colonne D (coordonnées complètes) mais qui doit se ranger qu'a partir de ce qui est entre crochet [(1a7):(1a 2999):(1a10)]. le problème c'est que toutes lignes doivent conserver et le format, les couleurs (colonne A) mais aussi la dernière colonne qui a des informations en multi-lignes. Malgré les différents principes de triage, c'est la dernière colonne qui n'arrive pas suivre, les lignes sont mélangées avec d'autres lignes ou carrément supprimées.
J'ai créer un formulaire de tri "Rangement" avec le bouton "CBRgt". Mais tous les codes fournis par l'IA a planté. Je ne sais pas coder, du moins pas assez pour faire cette partie. En bout de tableau j'avais ajouter 3 colonnes pour aider au trie mais ça n'a pas aider... j'ai mis ci dessous un petit (tres petit) modèle du tableau "Carte" (nom d'origine) pour vous donner une idée de ce a quoi je me confronte. Je rajoute le code de l'IA mais bon...
Merci de me guider et de m'aider si vous le pouvez:

(pourquoi une IA ? parce que je ne sais pas coder, tout simplement)

Private Sub CBRgt_Click()
Dim ws As Worksheet
Set ws = Sheets("Carte")
Dim LastRow As Long
LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).row

' DB à DD sont utilisés pour le tri
Dim colX As Integer, colY As Integer, colZ As Integer
colX = ws.Columns("DB").Column
colY = ws.Columns("DC").Column
colZ = ws.Columns("DD").Column

' Extraire x, y, z dans DB, DC, DD
Dim i As Long
For i = 3 To LastRow
Dim coord As String
coord = ws.Cells(i, "D").value
Dim parts() As String
parts = Split(Mid(coord, 2, Len(coord) - 2), ":") ' Supprimer les crochets et diviser
If UBound(parts) = 2 Then
ws.Cells(i, colX).value = Val(parts(0)) ' x
ws.Cells(i, colY).value = Val(parts(1)) ' y
ws.Cells(i, colZ).value = Val(parts(2)) ' z
End If
Next i

' Trier par x, y, z
With ws.Sort
.SortFields.Clear
.SortFields.Add Key:=ws.Cells(3, colX), Order:=xlAscending
.SortFields.Add Key:=ws.Cells(3, colY), Order:=xlAscending
.SortFields.Add Key:=ws.Cells(3, colZ), Order:=xlAscending
.SetRange ws.Range("A3:DD" & LastRow)
.Header = xlNo
.Apply
End With
' Optionnellement, nettoyer les colonnes temporaires si nécessaire
End Sub

Edit modo : merci de mettre le code entre balises SVP

j'avais essayer avec un bouton activex directement sur la feuille cela a marché puis pour une raison ou mise a jour excel, je n'ai eu que des defaut

Sub TrierLesCoordonnees()
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Carte")

    Dim lastRow As Long
    lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row

    Dim i As Long
    Dim coordonnees As Variant
    Dim arr() As String
    Dim cell As Range
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")

    ' Boucle à travers chaque cellule dans la colonne D à partir de la ligne 3
    For Each cell In ws.Range("D3:D" & lastRow)
        coordonnees = cell.Value
        ' Extraire les coordonnées entre les crochets
        arr = Split(Mid(coordonnees, InStr(coordonnees, "[") + 1, InStr(coordonnees, "]") - InStr(coordonnees, "[") - 1), ":")
        ' Ajouter les coordonnées et la référence de la cellule au dictionnaire
        If UBound(arr) = 2 Then
            ' Stocker les coordonnées sous forme de tableau dans le dictionnaire
            dict(cell.Address) = Array(CLng(arr(0)), CLng(arr(1)), CLng(arr(2)))
        End If
    Next cell

    ' Trier le dictionnaire par les valeurs (coordonnées)
    Set dict = SortDictionaryByValue(dict)

    ' Réarranger les lignes selon l'ordre trié
    Dim arrSorted As Variant
    ReDim arrSorted(1 To dict.Count, 1 To ws.Columns("DA").Column)

    i = 1
    For Each key In dict.keys
        For j = 1 To ws.Columns("DA").Column
            arrSorted(i, j) = ws.Range(key).EntireRow.Cells(1, j).Value
        Next j
        i = i + 1
    Next key

    ' Copier les données triées dans la feuille, en commençant par la ligne 3
    ws.Range("A3:DA" & lastRow).Value = arrSorted

    MsgBox "Tri terminé!", vbInformation
End Sub

' Fonction pour trier un dictionnaire par valeurs
Function SortDictionaryByValue(dict As Object) As Object
    Dim arrayKeys() As Variant
    Dim arrayItems() As Variant
    Dim i As Long
    arrayKeys = dict.keys
    arrayItems = dict.items
    Call BubbleSort(arrayItems, arrayKeys)
    Set SortDictionaryByValue = CreateObject("Scripting.Dictionary")
    For i = 0 To dict.Count - 1
        SortDictionaryByValue.Add arrayKeys(i), arrayItems(i)
    Next i
End Function

' Algorithme de tri à bulles modifié pour trier des tableaux de coordonnées
Sub BubbleSort(arr() As Variant, arrKeys() As Variant)
    Dim i As Long, j As Long
    Dim temp As Variant
    For i = LBound(arr) To UBound(arr) - 1
        For j = i + 1 To UBound(arr)
            If CompareCoordinates(arr(i), arr(j)) Then
                ' Échanger les valeurs
                temp = arr(i)
                arr(i) = arr(j)
                arr(j) = temp
                ' Échanger les clés
                temp = arrKeys(i)
                arrKeys(i) = arrKeys(j)
                arrKeys(j) = temp
            End If
        Next j
    Next i
End Sub

' Fonction pour comparer deux tableaux de coordonnées
Function CompareCoordinates(coord1 As Variant, coord2 As Variant) As Boolean
    For i = 0 To 2
        If coord1(i) < coord2(i) Then
            CompareCoordinates = False
            Exit Function
        ElseIf coord1(i) > coord2(i) Then
            CompareCoordinates = True
            Exit Function
        End If
    Next i
    CompareCoordinates = False
End Function

c'était le dernier a bien fonctionner, depuis c'est devenu impossible

merci pour vos conseils et aides

Eric

Bonsoir,

Quand on ne sait pas coder... pourquoi vouloir utiliser VBA je ne comprendrais jamais

Sinon : https://www.google.com/search?q=tableau+a+classer+VBA

A+

bonjour et merci pour votre réponse

re bonjour.

ce que vous auriez pu répondre plutôt que de me renvoyer sur un lien c'est par exemple le code suivant

Sub TrierSurCarte()
    Application.ScreenUpdating = False
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Carte")

    ' Trouver la dernière ligne avec des données dans la colonne D
    Dim LastRow As Long
    LastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).row

    ' Identifier la dernière colonne utilisée sur la ligne 3, qui devrait être DA
    Dim LastColumn As Long
    LastColumn = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column

    ' Ajouter des colonnes temporaires pour x, y, z à la fin
    Dim colX As Long, colY As Long, colZ As Long
    colX = LastColumn + 1
    colY = colX + 1
    colZ = colY + 1

    Dim i As Long
    Dim coord As String
    Dim coordParts() As String

    ' Extraire les composants x, y, z des coordonnées
    For i = 3 To LastRow
        coord = ws.Cells(i, "D").value
        If InStr(coord, "[") > 0 And InStr(coord, "]") > 0 Then
            coordParts = Split(Mid(coord, InStr(coord, "[") + 1, InStr(coord, "]") - InStr(coord, "[") - 1), ":")
            If UBound(coordParts) = 2 Then
                ws.Cells(i, colX).value = Val(coordParts(0)) ' x
                ws.Cells(i, colY).value = Val(coordParts(1)) ' y
                ws.Cells(i, colZ).value = Val(coordParts(2)) ' z
            End If
        End If
    Next i

    ' Trier le tableau
    ws.Sort.SortFields.Clear
    ws.Sort.SortFields.Add Key:=ws.Cells(3, colX), Order:=xlAscending
    ws.Sort.SortFields.Add Key:=ws.Cells(3, colY), Order:=xlAscending
    ws.Sort.SortFields.Add Key:=ws.Cells(3, colZ), Order:=xlAscending
    ws.Sort.SetRange ws.Range(ws.Cells(3, 1), ws.Cells(LastRow, colZ))
    ws.Sort.Header = xlNo
    ws.Sort.Apply

    ' Supprimer les colonnes temporaires pour les coordonnées x, y, z
    ws.Columns(colZ).Delete
    ws.Columns(colY).Delete
    ws.Columns(colX).Delete
    Application.ScreenUpdating = True
End Sub

relier a un bouton sur la feuille, le résultat est celui que je cherchais. Le sujet est donc résolut.
Belle fin de journée.

Re,

Ecoutez, c'est vous lespert (joke)

Avec un peu de recherche, vous avez trouvez... vous voyez

Je pense qu'il est inutile d'en rajouter, le sujet est clos.