Petite contribution - Ordre des colonnes par variable tableau et filtre tableau à 2 dimensions

**MarcelG** · 22/06/2015, 18h23

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.

**MarcelG** · 23/06/2015, 11h01

Bonjour au Forum,

Pas de commentaires?

Invité · 23/06/2015, 13h30

Bonjour,
personnellement, j'utilise de dictionnaires!

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
DicoSource.add "titre1",30
 
DicoCible.add "titre1",1

je lie les colonnes entre elles par leurs entêtes!

**MarcelG** · 23/06/2015, 13h49

Salut Rdurupt,

Merci pour ta réponse.

Par curiosité, et pour nos lecteurs, dans le cas de X colonnes, pourrais-tu retourner un exemple de développement?

Par avance, merci.

**joe.levrai** · 23/06/2015, 14h12

Bonjour,

dans le cas de X colonnes, rdurupt va probablement proposer deux tableaux de X éléments
le premier tableau donne la colonne de départ
le second, la colonne d'arrivée

ensuite un petit boucle sur chaque élément pour créer le dictionnaire

et s'il propose encore plus concis, je dis bravo (comme souvent

)

de mon côté, je me pose la question de l'utilité d'un code si complexe.
j'ai cru comprendre que le premier objectif est de réagencer des colonnes ?
quelques Cut / Insert de ces colonnes font normalement l'affaire ? Quitte a reprendre l'idée d'un tableau de correspondance pour faire un boucle

j'ai un programme qui converti une BDD brute en BDD retravaillée (pour les utilisateurs), dans laquelle je dois notamment "mélanger" différemment les colonnes
le déplacement/création des colonnes est bourrin au pas possible (pas de matrice, pas de boucle) , mais ça marche

voici la partie où je mélange les colonnes et modifie certaines données (la suite du code sort du cadre de ce fil)

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
Application.ScreenUpdating = False
 
' pour convertir les Nom de mois en Numéro de mois
NomMois = Array("MAI", "JUIN", "JUILLET", "AOUT", "SEPTEMBRE", "OCTOBRE", "NOVEMBRE", "DECEMBRE", "JANVIER", "FEVRIER", "MARS", "AVRIL")
NumMois = Array(5, 6, 7, 8, 9, 10, 11, 12, 1, 2, 3, 4)
 
With ThisWorkbook.Worksheets("Feuil3")
 
 
    ' réagencement et/ou création de colonnes
    ' pour obtenir la même structure que dans la BDD FOCUS
    .Columns(14).Insert: .Cells(1, 14).Value = "DELAIS"
    .Columns(13).Cut: .Columns(12).Insert
    .Columns(10).Cut: .Columns(12).Insert
    .Columns(8).Cut: .Columns(11).Insert
    .Columns(8).Cut: .Columns(10).Insert
    .Columns(2).Cut: .Columns(8).Insert
    .Columns(6).Insert: .Cells(1, 6).Value = "POLE"
    .Columns(4).Insert: .Cells(1, 4).Value = "SEMAINE"
    .Columns(3).Insert: .Cells(1, 3).Value = "TRIMESTRE"
    .Columns(2).Insert: .Cells(1, 2).Value = "DATE"
    .Columns(1).Cut: .Columns(12).Insert
 
    ' dernière ligne/colonne de la plage (sans la ligne des titres)
    DerLig = .Cells(.Rows.Count, 2).End(xlUp).Row
    DerCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
 
    ' mise sous tableau virtuel des données pour les travailler
    Tablo = .Range(.Cells(2, 1), .Cells(DerLig, DerCol))
 
    ' sur chaque ligne du tableau des données
    For i = LBound(Tablo, 1) To UBound(Tablo, 1)
        For j = LBound(NomMois) To UBound(NomMois)
            ' recherche du mois
            If Tablo(i, 4) = NomMois(j) Then
                ' remplacement par le numéro de jour
                Tablo(i, 4) = NumMois(j)
                ' reconstitution de la date jj/mm/aaaa
                Tablo(i, 1) = CDate(Tablo(i, 6) & "/" & Tablo(i, 4) & "/" & Tablo(i, 2))
                ' calcul du numéro de trimestre
                Tablo(i, 3) = DatePart("q", Tablo(i, 1), vbMonday, vbFirstJan1)
                ' calcul du numéro de semaine
                Tablo(i, 5) = DatePart("ww", Tablo(i, 1), vbMonday, vbFirstJan1)
                ' si pas d'affectation : on met le nom de l'équipe
                If Tablo(i, 13) = "" Then Tablo(i, 13) = Tablo(i, 7)
                ' écriture du pole
                Tablo(i, 8) = Mid(Tablo(i, 7), 7)
                ' écriture du site
                Tablo(i, 7) = Mid(Tablo(i, 7), 1, 5)
 
                ' si le délai est négatif
                If Tablo(i, 1) - Tablo(i, 17) < 0 Then
                    ' on met 0
                    Tablo(i, 18) = 0
                Else
                    ' sinon on calcule le délai
                    Tablo(i, 18) = Tablo(i, 1) - Tablo(i, 17)
                End If
 
                Exit For
            End If
        Next j
    Next i
 
    ' recopie des données retravaillées sur la plage
    .Range(.Cells(2, 1), .Cells(DerLig, DerCol)).Value = Tablo
End With

le traitement d'un millions de lignes prend environ 45 secondes

Invité · 23/06/2015, 15h02

en voici un

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
Sub Test()
Dim SourceColDico, CibleColDico, WbSource As Workbook, WbCible As Workbook
Dim ShSource As Worksheet, ShCible As Worksheet, R As Range
Dim C As Long, L As Long
Set WbCible = ThisWorkbook
Set WbSource = Workbooks.Open("C:\MyTest\A.xlsx")
 
Set SourceColDico = CreateObject("Scripting.dictionary")
Set CibleColDico = CreateObject("Scripting.dictionary")
'Je scan les colonnes de la source
Set ShSource = WbSource.Sheets("Data")
With ShSource.UsedRange
    For C = 1 To .Columns.Count
        If SourceColDico.exists(.Cells(1, C)) = False Then SourceColDico.Add .Cells(1, C), C
    Next
End With
'je scan le colonnes de la cible
Set ShCible = WbCible.Sheets("Data")
With ShCible.UsedRange
    For C = 1 To .Columns.Count
        If CibleColDico.exists(.Cells(1, C)) = False Then CibleColDico.Add .Cells(1, C), C
    Next
End With
'j'eface la cible
ShCible.UsedRange.Clear
Set R = ShSource.UsedRange
For L = 1 To R.Rows.Count 'je parcour la sourc et j'enrichi la cible
    For C = 1 To R.Columns.Count
        ShCible.Cells(L, CibleColDico(R(1, C))) = R(1, C)
    Next
Next
'la j'invers le processus
ShSource.UsedRange.Clear
Set R = ShCible.UsedRange
For L = 1 To R.Rows.Count
    For C = 1 To R.Columns.Count
        ShCible.Cells(L, SourceColDico(R(1, C))) = R(1, C)
    Next
Next
'et là je parcour la sour pour connetre la valeur de la cible
For Each elt In ShSource.Keys
    Debug.Print ShCible(elt)
Next elt
End Sub

Petite contribution - Ordre des colonnes par variable tableau et filtre tableau à 2 dimensions

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager