Sub ClasserColonnes()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim col%, P1 As Range, P2 As Range, i%, n
Application.ScreenUpdating = False
col = Feuil2.Cells(1, Feuil2.Columns.Count).End(xlToLeft).Column
Set P1 = Feuil1.Columns(1).Resize(, col)
Set P2 = Feuil2.Rows(1)
1 For i = 1 To col
If P1.Cells(1, i) <> "" Then
n = Application.Match(P1.Cells(1, i), P2, 0)
If IsError(n) Then MsgBox "Revoyez les titres en Feuil2 !": Exit Sub
If i <> n Then
P1.Columns(i).Cut
P1.Columns(n + 1).Insert
GoTo 1
End If
End If
Next
Application.Goto P1.Cells(1)
End Sub
... j'espère que tu ne m'en voudras pas de squatter ton fichier...
Sub ClasserColonnes()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim col1%, col%, P1 As Range, P2 As Range, i%, n
Application.ScreenUpdating = False
col1 = Feuil1.Cells(1, Feuil1.Columns.Count).End(xlToLeft).Column
col = Feuil2.Cells(1, Feuil2.Columns.Count).End(xlToLeft).Column
col = Application.Max(col1, col)
Set P1 = Feuil1.Columns(1).Resize(, col)
Set P2 = Feuil2.Rows(1)
1 For i = 1 To col
If P1.Cells(1, i) <> "" Then
n = Application.Match(P1.Cells(1, i), P2, 0)
If IsError(n) Then MsgBox "Revoyez les titres en Feuil2 !": Exit Sub
If i <> n Then
P1.Columns(i).Cut
P1.Columns(n - (i < n)).Insert 'True se convertit en -1
GoTo 1
End If
End If
Next
Application.Goto P1.Parent.[A1]
End Sub
Sub ClasserColonnes()
'Feuil1 et Feuil2 sont les CodeNames des feuilles
Dim F As Worksheet, col1%, col%, P As Range, i%, n
Application.ScreenUpdating = False
Set F = Feuil1
col1 = F.Cells(1, F.Columns.Count).End(xlToLeft).Column
col = Feuil2.Cells(1, Feuil2.Columns.Count).End(xlToLeft).Column
col = Application.Max(col1, col)
Set P = Feuil2.Rows(1).Resize(, col)
1 For i = 1 To col
If F.Cells(1, i) <> "" Then
n = Application.Match(F.Cells(1, i), P, 0)
If IsError(n) Then MsgBox "Revoyez les titres en Feuil2 !": Exit Sub
If i <> n Then
F.Columns(i).Cut
F.Columns(n - (i < n)).Insert 'True se convertit en -1
GoTo 1
End If
End If
Next
Application.Goto F.[A1]
End Sub
la macro serait équivalente si c'était sur la même feuille que l'on déplacerait les colonnes ?
Sub ClasserColonnes()
Dim F1 As Worksheet, F2 As Worksheet, P As Range, i%, n
Set F1 = Feuil1: Set F2 = Feuil2 'CodeNames
Set P = Feuil2.Rows(1)
For i = 1 To F1.Cells(1, F1.Columns.Count).End(xlToLeft).Column
If F1.Cells(1, i) <> "" Then
n = Application.Match(F1.Cells(1, i), P, 0)
If IsError(n) Then MsgBox "Revoyez les titres en Feuil2 !": Exit For
F1.Columns(i).Copy F2.Cells(1, n)
End If
Next
If IsError(n) Then F2.Rows("2:" & F2.Rows.Count).Delete
Application.Goto F2.[A1]
End Sub
Sub ClasserColonnes()
Dim F1 As Worksheet, F2 As Worksheet, col%
Dim P As Range, c As Range, r As Range
Application.ScreenUpdating = False
Set F1 = Feuil1: Set F2 = Feuil2
col = F2.Cells(1, F2.Columns.Count).End(xlToLeft).Column
Set P = F2.[A1].Resize(, col + 1)
F1.[1:1].Insert 'ligne auxiliaire
For Each c In F1.[A2].Resize(, col)
Set r = P.Find(c, P(col + 1), xlValues, xlWhole)
If r Is Nothing Then MsgBox "Revoyez les titres en Feuil2 !": Exit For
c(0) = r.Column
If r = "" Then r.EntireColumn.Hidden = True 'masque la colonne
Next
If Not r Is Nothing Then F1.Columns(1).Resize(, col) _
.Sort F1.[A1], xlAscending, Header:=xlNo, Orientation:=xlLeftToRight 'tri
F1.[1:1].Delete 'suppression de la ligne auxiliaire
F2.Columns(1).Resize(, col).Hidden = False 'affichage des colonnes
Application.Goto F1.[A1]
End Sub
Sub essai()
Dim dercol As Integer, derlin As Integer, tablo
Dim n As Integer, m As Integer, col As Integer, y As Range
dercol = Sheets("Feuil1").Cells(1, Columns.Count).End(xlToLeft).Column
derlin = Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
tablo = Sheets("Feuil1").Range(Cells(1, 1).Address & ":" & Cells(derlin, dercol).Address)
Sheets("Feuil1").Range(Cells(1, 1).Address & ":" & Cells(derlin, dercol).Address).ClearContents
Sheets("Feuil2").Rows(1).Copy Destination:=Sheets("Feuil1").Range("A1")
Application.ScreenUpdating = False
For n = LBound(tablo, 2) To UBound(tablo, 2)
Set y = Sheets("Feuil1").Rows(1).Find(tablo(LBound(tablo, 1), n), LookIn:=xlValues, lookat:=xlWhole)
col = y.Column
For m = LBound(tablo, 1) + 1 To UBound(tablo, 1)
Sheets("Feuil1").Cells(m, col) = tablo(m, n)
Next
Next
Application.ScreenUpdating = False
End Sub
a défaut d’être aussi rapide
Sub ClasserColonnes()
Dim F1 As Worksheet, F2 As Worksheet, col1%, col%, c As Range, r As Range
Application.ScreenUpdating = False
Set F1 = Feuil1: Set F2 = Feuil2 'CodeNames des feuilles
col1 = F1.Cells(1, F1.Columns.Count).End(xlToLeft).Column
col = F2.Cells(1, F2.Columns.Count).End(xlToLeft).Column
col = Application.Max(col1, col)
F1.[1:1].Insert 'ligne auxiliaire
For Each c In F1.[A2].Resize(, col)
Set r = F2.[A1].Resize(, col).Find(c, , xlValues, xlWhole)
If r Is Nothing Then MsgBox "Revoyez les titres en Feuil2 !": Exit For
c(0) = r.Column
If r = "" Then r.EntireColumn.Hidden = True 'masque la colonne
Next
If Not r Is Nothing Then F1.Columns(1).Resize(, col) _
.Sort F1.[A1], xlAscending, Header:=xlNo, Orientation:=xlLeftToRight 'tri
F1.[1:1].Delete 'suppression de la ligne auxiliaire
F2.Columns(1).Resize(, col).Hidden = False 'affichage des colonnes
Application.Goto F1.[A1]
End Sub