Retrier les colonnes par rapport à une colonne de reference

bonjour,

j'ai une feuille qui se présente de la façon suivante

pays capitale pays ville

france paris espagne barcelone

espagne madrid belgique liege

italie rome autriche salzbourg

allemagne berlin italie milan

je voudrais obtenir la présentation suivante :

pays capitale ville

france paris

espagne madrid barcelone

italie rome milan

allemagne berlin

belgique liege

autriche salzbourg

quelqu'un a-t-il une idée ? (j'ai essayé avec un tableau croisé dynamique mais ça ne marche pas )

merci par avance

Bonjour et bienvenue,

Envoie la feuille avec sa structure réelle,

quelques lignes suffiront

Amicalement

Claude

le fichier test est en PJ

merci pour votre aide

re,

Il doit y avoir + court

Sub Tablo2()
Dim Lg%, Lg2%, i%, x%, cL%, A As Byte
    Application.ScreenUpdating = False
    '---- prépare ----
    Range("f:h").EntireColumn.Clear
        Lg = Range("a65536").End(xlUp).Row
        Columns(6).Insert
    Range("a1:a" & Lg).Copy Destination:=Range("f1")

        Lg2 = Range("f65536").End(xlUp).Row
    Range("c2:c" & Lg2).Copy Destination:=Range("f65536").End(xlUp)(2)
        Lg = Range("f65536").End(xlUp).Row

    Range("f1:f" & Lg).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:= _
    Range("o1:o2"), CopyToRange:=Range("g1"), Unique:=True
        Columns(6).Delete

    '---- valeurs ----
    Lg = Range("f65536").End(xlUp).Row
    Range("a1:c1").Copy Destination:=Range("f1")
    Range("h1") = "volume2"
    Range("b2:b3").Copy

    Range("g2:h" & Lg).PasteSpecial Paste:=xlPasteFormats
    Application.CutCopyMode = False
        cL = 7
    For A = 1 To 3 Step 2
        For i = 2 To Lg
            On Error Resume Next
            x = WorksheetFunction.Match(Cells(i, 6), Columns(A), 0)
            On Error GoTo 0
            If x > 0 Then
                Cells(i, cL) = Cells(i, cL) + Cells(x, A + 1)
                x = 0
            End If
        Next i
        cL = cL + 1
    Next A
        Application.Goto Range("a1"), Scroll:=True
End Sub

Amicalement

Claude

impressionnant

merci beaucoup

Si Ok, pour solder le poste, c'est ici