Bonjour à tous,

(Vu l'ampleur modeste du développement, je place ces 2 procédures dans le forum)

Temps 1 - Je cherchais à déplacer les colonnes d'une feuille de travail automatiquement suivant un ordre défini.
Temps 2 - Je souhaitais créer une 2ème feuille en filtrant la 1ère sur 1 critère sans passer par la commande filtre, mais plutôt par une variable tableau POUR LE FUN! Ce en m'inspirant d'u développement de J. Boisgontier (une mine d'or, cet homme là!)

A tout seigneur, tout honneur.
Voici un lien pointant vers un développement de l'ami mercatog
Il procède à linversion de 2 colonnes
inversion de 2 colonnes

-----------------------------------------------------------------------------------------------------------------------------------------------

Principe :
Alimenter un tableau depuis la feuille de calcul, effacer les données puis retranscrire les différentes occurences du tableau

Donc ici, la colonne 33 devient la 1, la colonne 3 devient la 2, , la colonne 20 devient la 3, etc...

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
Option Explicit
Dim wkb As Workbook
 
Sub Change_ordre_colonnes()
 
Dim Tblo()
Dim derlign As Integer, dercol As Integer
Dim i As Integer
 
Application.ScreenUpdating = False
 
Set wkb = ThisWorkbook
 
With wkb.Worksheets("mafeuille")
 
        derlign = .Cells(.Rows.Count, 1).End(xlUp).Row
        dercol = .Cells(1, .Columns.Count).End(xlToLeft).Column
        ReDim Tblo(1 To derlign, 1 To dercol)
 
        With .Range("A1", .Cells(derlign + 1, dercol))
                Tblo = .Value
                .Clear
        End With
 
        For i = 1 To derlign
                .Cells(i, 1) = Tblo(i, 33)
                With .Cells(i, 2)
                        .Value = Tblo(i, 3)
                        With .Font
                            .Bold = True
                            .Color = -16777024
                        End With
                        .NumberFormat = "0"
                        .HorizontalAlignment = xlCenter
                End With
                With .Cells(i, 3)
                        .Value = Tblo(i, 20)
                        .NumberFormat = "0"
                End With
                .Cells(i, 4) = Tblo(i, 2)
                .Cells(i, 5) = Tblo(i, 4)
                With .Cells(i, 6)
                        .Value = Tblo(i, 9)
                        .NumberFormat = "#,##0.00 $"
                End With
                With .Cells(i, 7)
                        .Value = Tblo(i, 10)
                        .NumberFormat = "#,##0.00 $"
                End With
                .Cells(i, 8) = Tblo(i, 30)
                .Cells(i, 9) = Tblo(i, 7)
                .Cells(i, 10) = Tblo(i, 31)
                .Cells(i, 11) = Tblo(i, 34)
                .Cells(i, 12) = Tblo(i, 35)
                .Cells(i, 13) = Tblo(i, 36)
                .Cells(i, 14) = Tblo(i, 37)
                .Cells(i, 15) = Tblo(i, 38)
                .Cells(i, 16) = Tblo(i, 5)
        Next i
 
End With
 
Erase Tblo
 
End Sub
Dans un 2ème temps, même processus pour alimenter un tableau et le retranscrire, cette fois, avec des données filtrées manuellement.
Pour mémoire, la commande fitrer est utilisable pour les variables tableau à 1 dimension

Nota : tout ici n'est pas nécessaire à l'objet de ce post. Au demeurant, j'ai préféré conserver mon développement à l'éta initial. Au cas où...


Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
Sub Crée_wks_TOTO()
 
Dim wks_1 As Worksheet, wks_2 As Worksheet
Dim Tblo_1(), Tblo_2()
Dim derlign As Integer, dercol As Integer
Dim ligne As Integer, i As Integer, k As Integer
 
Application.ScreenUpdating = False
wkb.Worksheets.Add
Set wks_2 = ActiveSheet
Set wks_1 = Worksheets("mafeuille")
wks_2.Move After:=wks_1
 
With wks_1
    derlign = .Cells(.Rows.Count, 1).End(xlUp).Row
    dercol = .Cells(1, .Columns.Count).End(xlToLeft).Column
    ReDim Tblo(1 To derlign, 1 To dercol)
    Tblo_1 = .Range("A2", .Cells(derlign, dercol)).Value
End With
ReDim Tblo_2(1 To UBound(Tblo_1, 1), 1 To UBound(Tblo_1, 2))
ligne = 1
For i = LBound(Tblo_1) To UBound(Tblo_1)
  If Tblo_1(i, UBound(Tblo_1, 2)) = "TOTO" Then
    For k = 1 To UBound(Tblo_1, 2)
          Tblo_2(ligne, k) = Tblo_1(i, k)
    Next k
    ligne = ligne + 1
  End If
Next
With wks_1
        With .Range("A1", .Cells(1, dercol))
                .Font.Color = -65536
                .Font.Bold = True
                .Interior.Color = 13434879
                .HorizontalAlignment = xlCenter
                .Copy Destination:=wks_2.Range("A1")
                Application.ScreenUpdating = False
        End With
        .Range("A1", .Cells(derlign, dercol)).AutoFilter
End With
 
With wks_2
    .Range("A2").Resize(ligne, UBound(Tblo_2, 2)) = Tblo_2
    .Range("A1", .Cells(ligne, UBound(Tblo_2, 2))).AutoFilter
    .Name = "Résultats_TOTO_" & Format(Now, "yyyymd")
End With
 
wks_1.Name = "Résultats_" & Format(Now, "yyyymd")
 
Dim wks As Variant
 
For Each wks In Array(wks_1.Name, wks_2.Name)
    With Worksheets(wks)
        .Rows("1:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        With .Range("F2")
                .FormulaR1C1 = "=SUBTOTAL(2,R[3]C:R[2002]C)"
                .NumberFormat = "# ##0"
        End With
        With .Range("F3")
                .FormulaR1C1 = "=SUBTOTAL(9,R[2]C:R[2001]C)"
                .NumberFormat = "#,##0.00 $"
        End With
        With .Range("G3")
                .FormulaR1C1 = "=SUBTOTAL(9,R[2]C:R[2001]C)"
                .NumberFormat = "#,##0.00 $"
        End With
 
        'Mise en forme
        .Range("E2").FormulaR1C1 = "Nombre Total"
        .Range("E3").FormulaR1C1 = "Montant Total"
        With .Range("E2:E3")
                .Interior.Color = 6299648
                With .Font
                    .Color = -256
                    .Bold = True
                End With
                .HorizontalAlignment = xlRight
                .VerticalAlignment = xlBottom
                .IndentLevel = 1
        End With
        .Range("F3:G4").Interior.Color = 16751103
        With .Range("F2")
            With .Font
                .Color = -3407872
                .Bold = True
            End With
            .Interior.Color = 65535
        End With
        With .Range("F2:G3")
            .HorizontalAlignment = xlRight
            .VerticalAlignment = xlBottom
            .IndentLevel = 1
        End With
 
        .Range("A1", .Cells(derlign, dercol)).EntireColumn.AutoFit
    End With
Next wks
 
Set wks_2 = Nothing
Set wks_1 = Nothing
Set wkb = Nothing
 
End Sub
Voili! Voilou!

Si cela peut servir, tant mieux.
Si vous avez des commentaires, tant mieux également.