Discussion :

[Stef31]

Bonjour amis lecteurs,
Je souhaite faire un tri croissant de colonne sur plusieurs feuilles « en même temps » :
En supposant pour simplifier que le nbr max de ligne excel est 10,
J’ai :
Feuille1 :

A1 à A4 = 0 et B1 à B4= 1 à 4

A5 à A8 = 1 et B5 à B8= 5 à 8

A9 à A10 = 2 et B9 à B10= 9 à 10

Feuille2 :

A1 à A2 = 2 et B1 à B2= 11 à 12

A3 à A7 = 0 et B3 à B7= 13 à 17

A8 à A10 = 1 et B8 à B10= 18 à 20

Feuille3 :

A1 = 1 et B1 = 21

A2 à A6 = 2 et B2 à B6= 22 à 26

Et je voudrais :
Feuille1 :

A1 à A8 = 0 et B1 à B8= 1 à 4 et 13 à 17

A9 à A10 = 1 et B9 à B10= 5 à 6

Feuille2 :

A1 à A6 = 1 et B1 à B2= 7 à 8 et 18 à 21

A10 = 2 et B8 à B10= 11

Feuille3 :

A1 à A6 = 2 et B2 à B6= 12 et 22 à 26

Le nombre de feuille étant variable.
Voilà, merci de votre lecture et de vos réponse,
J’espère que cela est possible ca je n’ai pas le début d’un commencement d’idée.
Cdt
Stéphane

[Kimy_Ire]

Bonjour Stef31,

Absolument RIEN compris !
Il semblerait que je ne soit pas le seul au vu du nombre de réponses. ^^

Cordialement,
Kimy

[Stef31]

Bonjour,
Pour faire encore plus simple, je souhaite faire un tri croissant sur une colonne (genre colonne A) mais sur plusieurs feuille a la fois.
En gros, j'ai un fichier txt qui fait 3 millions de lignes. vu que excel n'en prend qu'1.04millions par feuille, j'ai réparti mon fichier txt sur 3 feuilles avec les requetes Recordset. Mais je n'arrive pas a faire le tri sur les 3 feuilles.
J'espère que c'est plus claire
Merci

[Kimy_Ire]

Bonjour Stef31,

Voici pour toi !
J'ai utilisé la fonction QuickSort2 trouvée sur Internet.

Puis après, je me suis pris la tête en pensant que ça allait être tout bête... mais pas tant... finalement.

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
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
Option Explicit
 
Sub tri_colA()
Dim oRng As Range
Dim oWksh As Worksheet
Dim i As Long, j As Long
Dim Valeur() As Double
Dim Valeur2()
Dim n As Long
Dim cnt As Long
Dim boucle As Integer
Dim oMax As Long
Dim oTemp() As Double
 
'***************************************************************************************'
'                   Récupération des valeurs de l'ensemble des feuilles                 '
'***************************************************************************************'
n = 1
ReDim Valeur(1 To 2, 1 To n)
For Each oWksh In ActiveWorkbook.Worksheets
    'If oWksh.Name <> "Feuil4" Then
    With oWksh
        Set oRng = .Range("A1")
        For i = 0 To .Cells(Rows.Count, 1).End(xlUp).Row - 1
            If IsNumeric(oRng.Offset(i, 0)) Then
                ReDim Preserve Valeur(1 To 2, 1 To n)
                Valeur(1, n) = oRng.Offset(i, 0)
                Valeur(2, n) = oRng.Offset(i, 1)
                n = n + 1
            Else
                MsgBox "Une valeur en colonne A n'est pas numérique."
                Exit Sub
            End If
        Next i
    End With
    'End If
Next oWksh
'Utilisation de QuickSort2 sur la "première colonne" afin de trier l'ensemble des données
QuickSort2 Valeur, 1, 1
 
 
'***************************************************************************************'
'       Gestion du tri sur la deuxième colonne en fonction de la première               '
'***************************************************************************************'
oMax = 1
boucle = 1
Do While oMax < UBound(Valeur, 2)
    n = 1
    'i =
 
    Do While Valeur(1, oMax) = Valeur(1, oMax + 1)
        oMax = oMax + 1
        If oMax + 1 > UBound(Valeur, 2) Then
            Exit Do
        End If
    Loop
 
    ReDim oTemp(1 To 2, 1 To oMax - boucle + 1)
 
    'Création du tableau temporaire
    For i = LBound(oTemp, 1) To UBound(oTemp, 1)
        For j = LBound(oTemp, 2) To UBound(oTemp, 2)
            oTemp(i, j) = Valeur(i, j + boucle - 1)
        Next j
    Next i
    'Utilisation de QuickSort2 sur un sous-ensemble du tableau principal (tableau temporaire)
    QuickSort2 oTemp, 1, 2
 
    'Recopie du tableau temporaire, trié
    For i = LBound(oTemp, 1) To UBound(oTemp, 1)
        For j = LBound(oTemp, 2) To UBound(oTemp, 2)
            Valeur(i, j + boucle - 1) = oTemp(i, j)
        Next j
    Next i
 
    boucle = oMax + 1
    oMax = oMax + 1
Loop
 
 
'***************************************************************************************'
'            Réalimentation des feuilles en fonction des ranges utilisées               '
'***************************************************************************************'
boucle = 0
For Each oWksh In ActiveWorkbook.Worksheets
    'If oWksh.Name <> "Feuil4" Then
    With oWksh
        cnt = .UsedRange.Columns(1).Cells.Count
        For i = 1 To cnt
            .Range("A1").Offset(i - 1, 0) = Valeur(1, i + boucle)
            .Range("A1").Offset(i - 1, 1) = Valeur(2, i + boucle)
        Next i
        boucle = boucle + cnt
    End With
    'End If
Next oWksh
 
End Sub
 
' Sort a 2-dimensional array on either dimension
' Omit plngLeft & plngRight; they are used internally during recursion
' Sample usage to sort on column 4
' Dim MyArray(1 to 1000, 1 to 5) As Long
' QuickSort2 MyArray, 2, 4
' Dim MyArray(1 to 5, 1 to 1000) As Long
' QuickSort2 MyArray, 1, 4
Public Sub QuickSort2(ByRef pvarArray As Variant, plngDim As Long, plngCol As Long, Optional ByVal plngLeft As Long, Optional ByVal plngRight As Long)
    Dim lngFirst As Long
    Dim lngLast As Long
    Dim varMid As Variant
    Dim varSwap As Variant
    Dim c As Long
    Dim cMin As Long
    Dim cMax As Long
 
    cMin = LBound(pvarArray, plngDim)
    cMax = UBound(pvarArray, plngDim)
    Select Case plngDim
        Case 1
            If plngRight = 0 Then
                plngLeft = LBound(pvarArray, 2)
                plngRight = UBound(pvarArray, 2)
            End If
            lngFirst = plngLeft
            lngLast = plngRight
            varMid = pvarArray(plngCol, (plngLeft + plngRight) \ 2)
            Do
                Do While pvarArray(plngCol, lngFirst) < varMid And lngFirst < plngRight
                    lngFirst = lngFirst + 1
                Loop
                Do While varMid < pvarArray(plngCol, lngLast) And lngLast > plngLeft
                    lngLast = lngLast - 1
                Loop
                If lngFirst <= lngLast Then
                    For c = cMin To cMax
                        varSwap = pvarArray(c, lngFirst)
                        pvarArray(c, lngFirst) = pvarArray(c, lngLast)
                        pvarArray(c, lngLast) = varSwap
                    Next
                    lngFirst = lngFirst + 1
                    lngLast = lngLast - 1
                End If
            Loop Until lngFirst > lngLast
            If plngLeft < lngLast Then QuickSort2 pvarArray, plngDim, plngCol, plngLeft, lngLast
            If lngFirst < plngRight Then QuickSort2 pvarArray, plngDim, plngCol, lngFirst, plngRight
        Case 2
            If plngRight = 0 Then
                plngLeft = LBound(pvarArray, 1)
                plngRight = UBound(pvarArray, 1)
            End If
            lngFirst = plngLeft
            lngLast = plngRight
            varMid = pvarArray((plngLeft + plngRight) \ 2, plngCol)
            Do
                Do While pvarArray(lngFirst, plngCol) < varMid And lngFirst < plngRight
                    lngFirst = lngFirst + 1
                Loop
                Do While varMid < pvarArray(lngLast, plngCol) And lngLast > plngLeft
                    lngLast = lngLast - 1
                Loop
                If lngFirst <= lngLast Then
                    For c = cMin To cMax
                        varSwap = pvarArray(lngFirst, c)
                        pvarArray(lngFirst, c) = pvarArray(lngLast, c)
                        pvarArray(lngLast, c) = varSwap
                    Next
                    lngFirst = lngFirst + 1
                    lngLast = lngLast - 1
                End If
            Loop Until lngFirst > lngLast
            If plngLeft < lngLast Then QuickSort2 pvarArray, plngDim, plngCol, plngLeft, lngLast
            If lngFirst < plngRight Then QuickSort2 pvarArray, plngDim, plngCol, lngFirst, plngRight
    End Select
End Sub

Par contre, je n'ai aucune idée de la durée d’exécution sur un nombre de variables énormes... Surtout la partie "Gestion du tri sur la deuxième colonne en fonction de la première"...

Bref, n'hésite pas à revenir vers moi !

Cordialement,
Kimy

[boisgontierjacques]

Bonjour,

Voir exemple en PJ

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
 
Option Compare Text
Sub essai()
  NbFeuilles = 3
  NbCol = 5
  Application.ScreenUpdating = False
  Dim a()
  For s = 1 To NbFeuilles
    Set f1 = Sheets("feuil" & s)
    temp = Range(f1.[A2], f1.[A65000].End(xlUp))
    n = n + UBound(temp)
    ReDim Preserve a(1 To 2, 1 To n)
    For i = LBound(temp) To UBound(temp)
      a(1, k + i) = temp(i, 1)
      a(2, k + i) = i + 100000 * s
    Next i
    k = k + UBound(temp)
  Next s
  Call tri(a, 1, n)
  '-----------------------  copie dans Feuil4,Feuil5,Feuil6
  d = 1
  bloc = Int(n / NbFeuilles)
  For s = 1 To NbFeuilles
    Set fd = Sheets("feuil" & s + NbFeuilles)
    f = d + bloc: If f > n Then f = n
    For i = d To f
       Set f = Sheets("feuil" & (a(2, i) \ 100000))
       k = a(2, i) Mod 100000 + 1
       f.Cells(k, 1).Resize(, NbCol).Copy fd.Cells(i + 2 - d, 1)
    Next i
    d = d + bloc + 1
  Next s
End Sub
 
Sub tri(a(), gauc, droi)  ' Quick sort
   ref = a(1, (gauc + droi) \ 2)
   g = gauc: d = droi
   Do
      Do While a(1, g) < ref: g = g + 1: Loop
      Do While ref < a(1, d): d = d - 1: Loop
        If g <= d Then
           temp = a(1, g): a(1, g) = a(1, d): a(1, d) = temp
           temp = a(2, g): a(2, g) = a(2, d): a(2, d) = temp
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
    If g < droi Then Call tri(a(), g, droi)
    If gauc < d Then Call tri(a(), gauc, d)
End Sub

Jacques Boisgontier

[Kimy_Ire]

Bonjour boisgontierjacques,

Il me semble que ton code ne tri pas également sur la deuxième colonne.
Sinon, je veux bien que tu me dises où tu exécutes cela dans ton code.
C'est ce qui m'a pris le plus de temps ! ^^

Cordialement,
Kimy

[Stef31]

Bonjour Kimy_Ire,
gd coup de chapeau pour la réactivité, merci bcp.
j'ai insérer ton code dans ma macro, mais elle a planter car pas assez de mémoire ds le PC.
J'ai du en trouver un un peu plus performant.
Par contre elle plante lors de la réalimentation sur la ligne boucle = boucle + cnt
avec boucle = 0 et cnt = 1048569 et comme message d'erreur "erreur d'exécuion6: Dépassement de capacité"

AS tu une idée?
merci

Bonjour boisgontierjacques,
je me pose la question de savoir si cela fonctionne avec plus de lignes, car avec xl2010, les 65000 lignes des 3 feuilles peuvent tenir sur une avec un simple copier/coller.
pensez-vous que si je replace le [A65000] par [A1048576] cela va fonctionner?
Merci
Cdt
Stef

[Kimy_Ire]

Bonjour Stef31,

Dans la déclaration des variables, passes tous les Integer en Long.
Le dépassement de capacité ne devrait plus intervenir.

Cordialement,
Kimy

[Stef31]

Encore tout juste! chapeau!
La macro entière met un peu de tps à s'exécuter, donc je ne fermerai le fil qu'après avoir bien vérifier le résultat.
On s'approche tt de même bien de la solution.

Je me permet de poser une petite question subsidiaire:
j'utilise une boucle for pour remplir ligne par ligne une colonne.
Y-a-t-il une solution plus élégante?

Encore merci bcp pour la rapidité et l'efficacité de l'intervention

[Kimy_Ire]

Je me permet de poser une petite question subsidiaire:
j'utilise une boucle for pour remplir ligne par ligne une colonne.
Y-a-t-il une solution plus élégante?

Cela dépend simplement de la source de tes données.
Si ces-dernières proviennent d'une feuille Excel, il y a beaucoup plus simple.
Cependant, si ce n'est pas le cas, il n'y a qu'avec ton code que la communauté pourra t'aider à optimiser celui-ci.

Cordialement,
Kimy

[Stef31]

Bonjour Kimy_Ire,
voici mes bout de code:
dans un premier temps j'ouvre mes fichiers txt avec:

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
Dim VarTabSplit
Dim intCnt As Integer
Dim messageboucle As String
Dim choix_fichier
Dim bid0, bid2
'définition pour ouverture gros fichier
Dim Cn As Object, Rs As Object
Dim strFullName As Variant
Dim longfichier, longrepertoire As String
 
 
fichier = Application.GetOpenFilename("Text Files (*.txt), *.txt", , , , True)
 
If IsArray(fichier) Then
    For choix_fichier = LBound(fichier, 1) To UBound(fichier, 1)
        nom_fich_ouvert = fichier(choix_fichier)
        VarTabSplit = Split(nom_fich_ouvert, "\")
        chemin_sauvegarde_final = ""
        For intCnt = 0 To UBound(VarTabSplit) - 2
            chemin_sauvegarde_final = chemin_sauvegarde_final & VarTabSplit(intCnt) & "\"
        Next intCnt
        chemin_sauvegarde_final = chemin_sauvegarde_final & "Fichiers txt SAMS\"
        longfichier = Dir(fichier(choix_fichier))
        longrepertoire = Left(fichier(choix_fichier), Len(fichier(choix_fichier)) - (Len(longfichier) + 1))
        bid0 = Split(nom_fich_ouvert, "\")
        bid1 = bid0(UBound(bid0))
        bid2 = Split(bid1, "_")
        bid3 = bid2(LBound(bid2))
 
        Workbooks.Add
        Application.ScreenUpdating = False
 
        'Connection
        Set Cn = CreateObject("ADODB.Connection")
        Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & longrepertoire & ";" & _
            "Extended Properties=""text;HDR=Yes;FMT=Delimited"""
 
        'Requete
        Set Rs = CreateObject("ADODB.Recordset")
        Rs.Open "SELECT * FROM [" & longfichier & "]", Cn, 3, 1, 1
 
        'boucle sur le résultat de la requete
        While Not Rs.EOF
            'Ajout Feuille
            Sheets.Add after:=Sheets(Sheets.Count)
            'Ecriture des données dans la feuille
            '1048570 spécifie le nombre de lignes par feuille
            ActiveSheet.Range("A1").CopyFromRecordset Rs, 1048570
            Columns("A:A").Select
            Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
                :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), TrailingMinusNumbers:= _
                True
            Cells.Select
            Cells.EntireColumn.AutoFit
            incrément_feuille = incrément_feuille + 1
        Wend
 
        Rs.Close
        Set Rs = Nothing
        Cn.Close
        Set Cn = Nothing
        Application.ScreenUpdating = True
 
 
 
        'supprimer les feuilles vide
        Application.DisplayAlerts = False
        Sheets(Array("Feuil1", "Feuil2", "Feuil3")).Select
        ActiveWindow.SelectedSheets.Delete
        Application.DisplayAlerts = True
        Sheets(1).Select
 
     Next choix_fichier
Else
        MsgBox "Aucun fichier n'a été sélectionnné", vbExclamation, "Erreur"
        Exit Sub
End If
 
 
End Sub

et une fois que le fichier texte est ouvert (sur une ou plusieurs page), je fait simplement:

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
Private Sub UserForm_Activate()
 
'transforme les Rad en Deg
If valeur_offset_câble = 0 Then
    For i = 1 To derniereligne
        Cells(i, Theta_colonne_sams).Value = Cells(i, Theta_colonne_sams).Value * 180 / pi
        Cells(i, Phi_colonne_sams).Value = Cells(i, Phi_colonne_sams).Value * 180 / pi
        Cells(i, Phase_Etheta_colonne_sams).Value = Cells(i, Phase_Etheta_colonne_sams).Value * 180 / pi
        Cells(i, Phase_Ephi_colonne_sams).Value = Cells(i, Phase_Ephi_colonne_sams).Value * 180 / pi
    progression_ligne = i / derniereligne
    Call UpdateProgress_analyse_i(progression_ligne)
    Next i
Else
    For i = 1 To derniereligne
        Cells(i, Theta_colonne_sams).Value = Cells(i, Theta_colonne_sams).Value * 180 / pi
        Cells(i, Phi_colonne_sams).Value = Cells(i, Phi_colonne_sams).Value * 180 / pi
        Cells(i, Phase_Etheta_colonne_sams).Value = Cells(i, Phase_Etheta_colonne_sams).Value * 180 / pi
        Cells(i, Phase_Ephi_colonne_sams).Value = Cells(i, Phase_Ephi_colonne_sams).Value * 180 / pi
        Cells(i, Amp_Etheta_colonne_sams).Value = Cells(i, Phase_Etheta_colonne_sams).Value + valeur_offset_câble
        Cells(i, Amp_Ephi_colonne_sams).Value = Cells(i, Phase_Ephi_colonne_sams).Value + valeur_offset_câble
    progression_ligne = i / derniereligne
    Call UpdateProgress_analyse_i(progression_ligne)
    Next i
End If
Unload Frmprogression_analyse
 
End Sub
Public Sub UpdateProgress_analyse_i(progression_ligne)
With Frmprogression_analyse
    .FrameProgress1.Caption = Format(progression_ligne, "0%")
    .LabelProgress1.Width = progression_ligne * (.FrameProgress1.Width - 10)
    .Repaint
End With
End Sub

Donc je voulais savoir s'il y avait une astuce pour éviter la boucle for de la deuxieme partie.

Merci
Stef