[Optimisation] code VBA transposition lignes vers colonnes

[Staple1600]

Bonsoir,

Est-ce que vous voyez un moyen d'optimiser le temps de traitement de la macro de transposition?
(ou un autre type de syntaxe)
J'ai ajouté une seconde macro pour créer les conditions de tests
(Le classeur de test doit contenir deux feuilles)

Sub TransposeLIG_COL()
Dim a As Variant, b As Variant
Dim i&, j&, k&
Dim t0 As Double
'Heure départ
t0 = Timer
Application.ScreenUpdating = False
' passage en calcul sur ordre
Application.Calculation = xlCalculationManual
'si error, on saute à FIN: pour remettre le calcul en automatique
On Error GoTo FIN
a = ActiveSheet.Cells(1).CurrentRegion.Value
ReDim b(1 To UBound(a, 1) * (UBound(a, 2) - 2), 1 To 4)
For i = 2 To UBound(a, 1)
  For j = 3 To UBound(a, 2)
    k = k + 1
    b(k, 1) = a(i, 1): b(k, 2) = a(i, 2): b(k, 3) = a(1, j): b(k, 4) = a(i, j)
  Next j
Next i
Sheets(2).Cells(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
FIN:
If Err.Number > 0 Then MsgBox "Erreur n° " & Err.Number & vbLf & Err.Description
Application.Calculation = xlCalculationAutomatic
MsgBox Format(Timer - t0, "0.0 \ sec."), vbInformation, "Temps éxécution macro"
'crédits code: Peter_SSs, ma pomme
End Sub
Sub CreationDonnees()
'macro pour générer des données de test
Application.ScreenUpdating = False
[C1] = 1: [A2:B2] = Array(100002, "DATA2")
[C1:N1].DataSeries Rowcol:=xlRows, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
[B2:B30000].DataSeries Rowcol:=xlColumns, Type:=xlAutoFill, Date:=xlDay, Trend:=False
[A2:A30000].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
[C2:N30000] = "=RANDBETWEEN(1,500)": [C2:N30000] = [C2:N30000].Value
End Sub

PS: la macro de transposition est issue de mes archives (glanée sur le web anglophone)

Sur mon PC de test, le MsgBox affiche entre 9 à 10 secondes
(version Excel pour le test: 2013)
NB: Dans la réalité, le nombre de ligne peut aller jusqu'à plus ou moins 60 000 lignes.

Merci à ceux qui prendront le temps de s’intéresser à la question

 

[Staple1600]

Re

ma pomme
Tu as vu mon résultat sans l'Array? (message#11)

Est-ce qu'Excel préfère les processeurs Intel à ceux d'AMD?
Car je ne comprends pas pourquoi chez moi, j'ai un temps d’exécution largement supérieur à vous tous dans ce fil ???

 

[Simply]

Staple1600

J'ai testé votre code. Avant d'enregistrer les valeurs du tableau B dans la feuille, le cycle se termine dans 0,5 seconde.

Sheets(2).Cells(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
FIN:

Le temps restant est celui qui est strictement nécessaire pour copier les données de la feuille (il n’ya pas d’alternative!)

 

[mapomme]

Tu as vu mon résultat sans l'Array? (message#11)

Cela m'a 'étonné car tu doubles le temps d'exécution. Je pencherai comme responsable plutôt le processeur. N'aurais pas tu une autre bécane (au boulot par exemple) pour comparer.

 

[laurent950]

Bonsoir Staple1600, le Forum
j'ai fait le correctif je tombe sur le même résultat c'est incompressible (Même temps que vous)
Temps d’exécution = 1,4 secondes (Staple1600 et moi (Pas mieux)

Sub TransposeLIG_COL_Laurent()
    ' http://fordom.free.fr/tuto/OPTIMISATION.htm
    Dim a() As Variant
    Dim b() As Variant
    ' https://forum.excel-pratique.com/viewtopic.php?t=4163
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim t0 As Double
    Dim cpt As Long: cpt = 2
'Heure départ
    t0 = Timer
    Application.ScreenUpdating = False
' passage en calcul sur ordre
    Application.Calculation = xlCalculationManual
'si error, on saute à FIN: pour remettre le calcul en automatique
    On Error GoTo FIN
        a = ActiveSheet.Cells(1).CurrentRegion.Value
            ReDim b(LBound(a, 2) To (UBound(a, 1) * UBound(a, 2) - 2), 1 To 4)
                For j = 2 To UBound(a, 1)
                    For i = 3 To UBound(a, 2)
                        b(cpt, 1) = a(j, 1)
                        b(cpt, 2) = a(j, 2)
                        b(cpt, 3) = a(1, i)
                        b(cpt, 4) = a(j, i)
                        cpt = cpt + 1
                    Next i
                Next j
Sheets("TEST").Cells(1).Resize(UBound(b, 1), UBound(b, 2)).Value = b
FIN:
    If Err.Number > 0 Then MsgBox "Erreur n° " & Err.Number & vbLf & Err.Description
        Application.Calculation = xlCalculationAutomatic
        MsgBox Format(Timer - t0, "0.0 \ sec."), vbInformation, "Temps éxécution macro"
'crédits code: Peter_SSs, ma pomme
End Sub

 

[eriiic]

Bonjour à tous,

Sur mon PC pré-ado (10 ans, ça passe vite ) : 5.8 s
Si tes 4 Go étaient trop juste et te faisaient passer en mémoire virtuelle ?
Tu pourrais tester en faisant des blocs de 5 ou 10000 lignes.
Mais j'ai dans l'idée que ton processeur ne doit y être étranger. Il n'y a pas si longtemps que AMD était à la ramasse au niveau perf.
eric

 

[Staple1600]

Re

En refarfouillant dans mes archives dédiées à la transposition, j'ai retrouvé celle-ci (qui fait a moitié le boulot)
Et donc plus rapidement
Mais le problème reste le même (comme signalé par Simply)

Sub TransposeRows()
Dim i As Long, j As Long, k As Long, ur As Variant, tr As Variant
Dim thisVal As String, urMaxX As Long, urMaxY As Long, maxY As Long
Dim t0 As Double
'Heure départ
t0 = Timer
Application.ScreenUpdating = False
' passage en calcul sur ordre
Application.Calculation = xlCalculationManual
'si error, on saute à FIN: pour remettre le calcul en automatique
On Error GoTo FIN
    With ActiveSheet
        ur = .UsedRange
        urMaxX = UBound(ur, 1)
        urMaxY = UBound(ur, 2)
        maxY = urMaxX * urMaxY
        ReDim tr(2 To maxY, 1 To 3)
        k = 2
        For i = 2 To urMaxX
            For j = 2 To urMaxY
                thisVal = Trim(ur(i, j))
                If Len(thisVal) > 0 Then
                    If j = 2 Then
                        tr(k, 1) = Trim(ur(i, 1))
                        tr(k, 2) = Trim(ur(i, 2))
                        tr(k, 3) = Trim(ur(i, 3))
                        j = j + 1
                    Else
                        tr(k, 3) = thisVal
                    End If
                    k = k + 1
                Else
                    Exit For
                End If
            Next
        Next
    End With
    Sheets(2).Range(Sheets(2).Cells(2, 1), Sheets(2).Cells(maxY, 3)) = tr
FIN:
If Err.Number > 0 Then MsgBox "Erreur n° " & Err.Number & vbLf & Err.Description
Application.Calculation = xlCalculationAutomatic
MsgBox Format(Timer - t0, "0.0 \ sec."), vbInformation, "Temps éxécution macro"
'crédits code: paul bica, ma pomme
End Sub

Petite question subsidiaire*
Après exécution, j'ai fait un F5-> Cellules vides et là je constate que cela mouline, mouline, mouline
(et je vois défiler lentement dans la Zone Nom, les adresses des cellules vides.
C'est pareil chez vous?
(D'habitude, sur moins de lignes c'est immédiat, non ?)

PS: Je voulais utiliser ce code pour remplir les vides
[A1].CurrentRegion.Resize(, 2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
[[A1].CurrentRegion.Resize(, 2).Value = [A1].CurrentRegion.Resize(, 2).Value
Mais mauvaise idée

 

[Staple1600]

Bonsoir eriiiic

Mes 4Go en sont-ils vraiment?
Mémoire RAM installée: 4,00 Go (3.50 utilisable)

Laurent950
J'ai testé ton code (qui est quasi-identique à celui que j'utilise, non ?)
Résultat: 9.5 secondes.

 

[ThomasR]

dans ce cas le mieux est de ne pas écrire dans la feuille vue que le produit fini est un csv.

pousse ton pivo dans un string avec tes separateurs ";" et des chr(10) pour tes retours à la ligne puis tu flush directement dans un fichier texte

je fais cela très souvent c'est hyper rapide.

car je pense que tes problèmes de perf peuvent venir de plein de chose (install excel, version office, macro activé...) en zappant l'écriture dans la feuille tu peux atteindre des perfs encore meilleur que ce énoncé plus haut

 

[Staple1600]

Bonsoir ThomasR

C'est justement la piste que j'allais commencé à prendre en passant par un fsobj.CreateTextFile

pousse ton pivo dans un string avec tes separateurs ";" et des chr(10) pour tes retours à la ligne puis tu flush directement dans un fichier texte

Si tu as un exemple de code sous le coude, n'hésite pas à le publier, cela m'évitera de me coucher trop tard

Pour les performances à la ramasse, je mettrai aussi Windows 10 dans les causes
(Puisque c'est un PC à l'origine manufacturé avec W7 avec ensuite migration vers W10)
Quand à la version d'Excel (je l'ai indiqué plus haut : Excel 2013 Famille et Etudiant 32bit, CTR)

 

[ThomasR]

si tu as des problèmes de perf j'éviterais les createobject à tours de bras (même si je les aimes car c'est plus propre)
sinon il faut les passer en nothing à la fin

dans ton cas je ferais du basic iso excel 98 lol

un truc du genre

Open "C:\text.csv" For Output As #1
        Print #1, monString
        Close

 

[eriiic]

Re,

ton traitement par array me parait correct, tu auras du mal à gagner beaucoup dessus..
Sur les 5.8 s il ne prend que 0.44 s chez moi. Le reste c'est le collé de b

 

[ThomasR]

donc à la place de créer un tableau ou un array fais simple un string et tu le print dans ton fichier texte

 

[ThomasR]

après si tu veux pas te prendre la t^te à faire du rework de code tu ne crée pas de variable
tu ouvres le fichier texte avant tes boucles et tu écris directement ligne après ligne dans le fichier texte
tu fais un print pour chaque ligne

 

[ThomasR]

Si cela peut te faire gagner du temps.

Sub TransposeLIG_COL()
Dim a As Variant
Dim i&, j&
Dim t0 As Double
'Heure départ
t0 = Timer
Application.ScreenUpdating = False
' passage en calcul sur ordre
Application.Calculation = xlCalculationManual
'si error, on saute à FIN: pour remettre le calcul en automatique
On Error GoTo FIN
a = ActiveSheet.Cells(1).CurrentRegion.Value
Open "D:\text.csv" For Output As #1
For i = 2 To UBound(a, 1)
  For j = 3 To UBound(a, 2)
    Print #1, a(i, 1) & ";" & a(i, 2) & ";" & a(1, j) & ";" & a(i, j)
  Next j
Next i
Close

FIN:
If Err.Number > 0 Then MsgBox "Erreur n° " & Err.Number & vbLf & Err.Description
Application.Calculation = xlCalculationAutomatic
MsgBox Format(Timer - t0, "0.0 \ sec."), vbInformation, "Temps éxécution macro"
'crédits code: Peter_SSs, ma pomme
End Sub
Sub CreationDonnees()
'macro pour générer des données de test
Application.ScreenUpdating = False
[C1] = 1: [A2:B2] = Array(100002, "DATA2")
[C1:N1].DataSeries Rowcol:=xlRows, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
[B2:B30000].DataSeries Rowcol:=xlColumns, Type:=xlAutoFill, Date:=xlDay, Trend:=False
[A2:A30000].DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
[C2:N30000] = "=RANDBETWEEN(1,500)": [C2:N30000] = [C2:N30000].Value
End Sub

 

[ThomasR]

moi cela me créer le csv en 2,9 secondes