Transférer un tableau plus rapidement

[MJ13]

Bonjour à tous

J'ai un fichier avec des noms de dossiers et de fichiers.

je voudrais les mettre en tableau de 8 colonnes pour faire des planches contact.

J'ai fait une macro pour les dispatcher. Mais si j'ai 65 000 lignes, cela va prendre environ 6 minutes sur mon PC.

Pourrait-on aller plus vite en VBA avec la notion de tableaux que je ne maîtrise pas?

Voir pièce jointe.

Merci d'avance 😉.

 

[CBernardT]

Re : Transférer un tableau plus rapidement

Bonjour MJ13,

Un essai par tableau dynamique.

Cela semble fonctionner sur les 1000 lignes, à voir sur les 65000.

 

[MJ13]

Re : Transférer un tableau plus rapidement

Bonjour Bernard

Déjà, félicitation pour ton passage au rang de de Barbatruc. J'éspère que d'autres vont le signaler sinon...

Merci beaucoup pour ta macro qui à l'air ultra rapide (1 seconde, on dirait Bip Bip 🙂), mais sur un fichier d'un peu plus de 63000 lignes, il ne m'en trouve que environ 37000.

Comme cela me dépasse un peu tous ces codes de tableaux 😕.

Vois-tu d'où cela peut-il provenir?

 

[Odesta]

Re : Transférer un tableau plus rapidement

Bonjour à tous

Mon essai :

Sub transfert_tableau()
nb_colonne_max = 8
Dim mon_nouveau_tableau As Variant

'définir le tableau source :
mon_tableau = Sheets(1).Range("A2:B" & Sheets(1).Range("B65536").End(xlUp).Row).Value

'définir le tableau cible (10000 car on ne connait pas le nombre de ligne max)
ReDim mon_nouveau_tableau(1 To 10000, 0 To nb_colonne_max) '( 0 = colonne titre)

ligne = 1
col = 1
dossier_actu = mon_tableau(1, 1)
mon_nouveau_tableau(1, 0) = dossier_actu

For i = LBound(mon_tableau) To UBound(mon_tableau) 'pour toutes les valeurs du tableau source
    If mon_tableau(i, 1) = dossier_actu Then 'si le dossier de la ligne reste le meme...
        
        If col = nb_colonne_max + 1 Then 'colonne max atteinte
            col = 1
            ligne = ligne + 1
            mon_nouveau_tableau(ligne, 0) = dossier_actu
        End If
        
        mon_nouveau_tableau(ligne, col) = mon_tableau(i, 2)
        col = col + 1
    Else '...sinon changement de ligne
        ligne = ligne + 1
        col = 1
        dossier_actu = mon_tableau(i, 1)
        mon_nouveau_tableau(ligne, 0) = dossier_actu
        mon_nouveau_tableau(ligne, col) = mon_tableau(i, 2)
        
        col = col + 1
    End If
Next


'restitution du tableau
Sheets(2).Range("A1:I10000") = mon_nouveau_tableau

Cdt
Olivier

 

[Odesta]

Re : Transférer un tableau plus rapidement

J'avoue avoir quand même mis plus de temps à faire mon programme qui est sensiblement le même, (sauf la fin de celui de Bernard qui est bien plus jolie : .Range("A1").Resize(UBound(TabRes, 1), UBound(TabRes, 2)) = TabRes)
bravo !

EDIT :

...mais sur un fichier d'un peu plus de 63000 lignes, il ne m'en trouve que environ 37000...

Chez moi (Excel 2003) le code de Bernard fonctionne bien sur 65000 lignes
mais j'ai testé avec des noms de dossier indentique : y en a t-il beaucoup de différents ?

EDIT 2 : j'en dis pas mal des conneries quand même....

++
Olivier

 

[MJ13]

Re : Transférer un tableau plus rapidement

Re, Bonjour Odesta.

Merci beaucoup pour ta macro qui après une petite adaptation (en effet je peux avoir plus de 10000 dossiers différents).

Je passe d'environ 6 minutes à 3,7 secondes (soit 100 fois plus rapide, c'est cool 🙂).

"Je les aurais un jour les tableaux, je les aurais" 😛

Sub transfert_tableau()
'Odesta
t1 = Timer
nb_colonne_max = 8
Dim mon_nouveau_tableau As Variant
'définir le tableau source :
mon_tableau = Sheets(1).Range("A2:B" & Sheets(1).Range("B65536").End(xlUp).Row).Value
'définir le tableau cible (10000 car on ne connait pas le nombre de ligne max)
ReDim mon_nouveau_tableau(1 To 60000, 0 To nb_colonne_max) '( 0 = colonne titre)
ligne = 1
col = 1
dossier_actu = mon_tableau(1, 1)
mon_nouveau_tableau(1, 0) = dossier_actu
For i = LBound(mon_tableau) To UBound(mon_tableau) 'pour toutes les valeurs du tableau source
    If mon_tableau(i, 1) = dossier_actu Then 'si le dossier de la ligne reste le meme...
 
        If col = nb_colonne_max + 1 Then 'colonne max atteinte
            col = 1
            ligne = ligne + 1
            mon_nouveau_tableau(ligne, 0) = dossier_actu
        End If
 
        mon_nouveau_tableau(ligne, col) = mon_tableau(i, 2)
        col = col + 1
    Else '...sinon changement de ligne
        ligne = ligne + 1
        col = 1
        dossier_actu = mon_tableau(i, 1)
        mon_nouveau_tableau(ligne, 0) = dossier_actu
        mon_nouveau_tableau(ligne, col) = mon_tableau(i, 2)
 
        col = col + 1
    End If
 
Next
 
'restitution du tableau
Sheets(2).Range("A1:I60000") = mon_nouveau_tableau
t2 = Timer: MsgBox (t2 - t1)
End Sub

EDIT 2 : j'en dis pas mal des conneries quand même....

Moi, cela me plairaît de dire des c......es comme ça 😉.

 

[Odesta]

Re : Transférer un tableau plus rapidement

C'est un plaisir

Pour adapter le code de Bernard, il faut modifier le "Z / 3" en "Z / 2" voire en "Z"

Olivier

 

[CBernardT]

Re : Transférer un tableau plus rapidement

Re,

Bonjour à tous

essaie avec ce code :

Sub Img_Planche_Contact()
Dim i As Long, j As Byte, n As Long, Z As Long, Tablo, TabRes, T1, T2
T1 = Timer
With Sheets("Feuil1")
Tablo = .Range("A2:B" & .Range("A65536").End(xlUp).Row)
Z = UBound(Tablo, 1)
End With
ReDim TabRes(1 To Z, 1 To 9)
n = 1
For i = 1 To Z
TabRes(i, 1) = Tablo(n, 1)
For j = 2 To 9
If Tablo(n, 1) <> TabRes(i, 1) Then Exit For
TabRes(i, j) = Tablo(n, 2) ' Fin de la ligne avant 9
n = n + 1
If n > Z Then Exit For ' fin du tableau
Next j
If n > Z Then Exit For ' fin du tableau
Next i
Sheets.Add After:=Sheets(Sheets.Count)
With ActiveSheet
.Range("A1").Resize(UBound(TabRes, 1), UBound(TabRes, 2)) = TabRes
End With
T2 = Timer: MsgBox (T2 - T1)
End Sub

Le tableau TabRes est agrandi en nombre de lignes.

 

[MJ13]

Re : Transférer un tableau plus rapidement

Re

Merci Bernard.

Maintennant, c'est Ok. Au niveau du temps c'est idem que Olivier.

Bon, j'y vais 😉.