[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

 

[Hasco]

Bonjour,

Pour information sur mon Portable de 2013 - 2,4GHz - 4 GO Ram - Excel 2010 j'obtiens 5,9 secondes ce qui est pas mal du tout.

Passez une bonne journée

 

[Simply]

Bonjour,

Pour information sur mon Asus X55C Portable W10 - 2,2GHz - 6 GB Ram - Excel 2016 64 bit j'obtiens 2,8 secondes.
UBound(b, 1)
359988 Row

 

[zebanx]

Bonjour Staple1600, roblochon, simply, le forum

Sur 30000 lignes 3.1 secondes pour exécuter "TransposeLIG_COL"

excel 2007 - pc windows 7 - i5 - 8GO RAM -3.3 GHZ (cette donnée là apparait sur une surveillance générale du système mais me parait hautement discutable)

Du mal à comprendre pourquoi ton PC serait si lent...

@+

 

[mapomme]

Bonjour @Staple1600 , @Roblochon , @Simply , @zebanx ,

3.8 s sur Excel 2010, win 7, i5 3340M, 2,7GHz, 4 Go

 

[Staple1600]

Bonjour

Merci à tous pour vos tests et retours.
Je viens de refaire le test.
(en désactivant l'antivirus, désactivant les compléments COM d'Excel (qui se chargent pas défaut au démarrage d'Excel) et avec mon navigateur fermé)
Résultat: 9,5 sec.

Test sur fait sur : W10-1809 (64bits), AMD E-300 APU with Radeon, 1.3 Ghz, 4Go
Excel 2013 32bits (Famille et Etudiant)

J'ai aussi fait le test au boulot (W7 Pro + Excel 2010, 8Go ou 4Go je sais plus)
Mais en tout cas, c'est plus rapide <= 5sec.

Parmi vous tous, qui avaient testé, vous ne pas voyez une autre syntaxe VBA pour améliorer la chose ?
Je sais que la macro passe déjà par un Array mais vous ne voyez d'autres pistes?

 

[laurent950]

Bonsoir Staple1600, le Forum

Peut être en version Bi-Turbo cela peux être plus rapide a voir.

Sub TransposeLIG_COL()
    ' 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
'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, 2), LBound(a, 1) To UBound(a, 1))
                For i = LBound(a, 2) To UBound(a, 2)
                    For j = LBound(a, 1) To UBound(a, 1)
                        b(i, j) = a(j, i)
                    Next j
                Next i
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

cdt
laurent

 

[Staple1600]

Bonsoir

Laurent950
Chez moi, avec ton code, il y une erreur
Erreur n° 1004
Erreur définie par l'application ou par l'objet

 

[mapomme]

Bonsoir @Staple1600,

Juste par curiosité: quelle est ton temps d'exécution avec une méthode sans array ? (forcément un peu plus longue mais dans quelle mesure?)

 

[Simply]

Bonsoir

Note:
Avec la macro TransposeLIG_COL et nous ne rapportons pas le tableau de données dans la feuille, les temps baissent à 0,5 seconde.


Peut-être pouvez-vous charger un tableau en mémoire sans saisir directement les données dans la feuille.
Utilisation de la fonction () pour les recherches.

Voici un petit exemple pour charger des données en mémoire dans une fonction
Static collMarks As New Collection ...

 

[Staple1600]

Bonsoir ma pomme

Sans array, on double l'arrêt
20,4 sec.

Je suis parti sur autre piste* (CreateObject("System.Collections.ArrayList")
Mais je pédale dans la choucroute pour le moment
Certains parmi vous voient comment l'utiliser?
Je bloque au niveau de la transposition

Sub test()
Créer
TestArrayList
End Sub
Private Sub Créer()
[C1:N1] = [{1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}]
[C2:N5] = "=RANDBETWEEN(1,500)"
[B2:B5].FormulaR1C1 = "=""DATA""&ROW()"
[A2:A5] = "=TEXT(1000*ROW(),""0000"")"
[A1].CurrentRegion = [A1].CurrentRegion.Value
End Sub
Private Sub TestArrayList()
Dim rg As Range, c As Range
Set rg = Sheets(1).Cells(1).CurrentRegion
Application.ScreenUpdating = False
With CreateObject("System.Collections.ArrayList")
For Each c In rg: .Add c.Text: Next
Sheets(2).Cells(1).Resize(.Count) = Application.Transpose(.toarray)
End With
End Sub

*: Peut-être me fourvoie-je en suivant cette piste?
Si c'est le cas, prévenez-moi

 

[Staple1600]

Bonsoir Simply

Je viens juste de voir ton message
Je vais de ce pas tester ta PJ.

 

[Simply]

Bonsoir Staple1600

Je suis parti sur autre piste* (CreateObject("System.Collections.ArrayList")

https://analystcave.com/vba-arraylist-using-vba-arraylist-excel/

 

[Staple1600]

Re,

Simply
Je ne vois pas comment appliquer ton exemple pour ma problématique.
La problématique étant de transposer des données "réelles" agencées comme l'exemple généré par la macro CréationDonnées pour obtenir le résultat sur la feuille 2 après exécution de la macro TranspoLIG_COL().
La macro actuelle fait le job mais je me demandais si il y avait d'autre moyen de le faire et ce plus rapidement.
La solution de ma pomme (chez moi) augmente grandement le temps de traitement.

NB: Le but de cette transposition est d'agencer ainsi les données pour ensuite générer un CSV pour import dans un logiciel tiers (qui impose ce format "en colonne")

Merci pour le lien (que je connaissais) mais j'avais pas lu le bas de la page

On a regular basis use rather the VBA Collection instead of the VBA ArrayList

Donc je me fourvoyais, c'est que tu voulais me faire comprendre?

 

[mapomme]

Je suis parti sur autre piste* (CreateObject("System.Collections.ArrayList")

A priori, un ArrayList est une structure dont la taille varie en fonction des élements qu'on y insère ou qu'on supprime et dont les éléments sont accessible par un index. Dans notre cas on connait la taille du tableau final. Je ne vois pas ce que peut apporter la structure ArrayList mais je me trompe peut-être.