VBA : Amélioration macro

[ketamacanna]

Bonjour au forum,

Je souhaite améliorer le code d'une macro pour résoudre deux problèmes :
- dans le code ci-dessous : je souhaiterais remplacer "ReDim Preserve mytab2(65000, 6) par quelque chose du genre ReDim Preserve mytab2(a, 6) avec a le nombre de ligne qui varie. Cependant, il semblerait que redim preserve ne modifie que la dernière dimension du tableau, donc si quelqu'un a une idée, peut-être avec (ReDim Preserve mytab2(6,a) puis un transpose mais je bloque?

-lorque je supprime tous les "OUI" (colonnes "G" et "H" de l'Onglet 1), le code provoque une erreur, à cause de la taille du tableau.

Je joins le fichier avec les explications.

HELP.xls

(73 Kio) Téléchargé 7 fois

Code: Tout sélectionner

Option Base 1

Sub macrotest()
'BY Ketamacanna 15/02/11
Dim mytab1() As Variant, mytab2() As Variant, last_ligne1 As Long, last_ligne2 As Long, ws1 As Worksheet, ws2 As Worksheet

Set ws1 = Worksheets("Onglet 1")
Set ws2 = Worksheets("Onglet 2")
last_ligne1 = ws1.Cells(65000, 1).End(xlUp).Row
last_ligne2 = ws2.Cells(65000, 1).End(xlUp).Row

If last_ligne1 = 1 Then Exit Sub

mytab1() = ws1.Range("A2:H" & last_ligne1)

borne_dim1 = UBound(mytab1, 1)
borne_dim2 = UBound(mytab1, 2)

For i = 1 To borne_dim1

        If mytab1(i, 7) = "OUI" Or mytab1(i, 8) = "OUI" Then
        a = a + 1

                For j = 1 To 6
                ReDim Preserve mytab2(65000, 6)
                mytab2(a, j) = mytab1(i, j)
                Next j

        Else

        End If

Next i

Range("J2:O30") = mytab2

Erase mytab1, mytab2

End Sub

Merci à ceux qui pourront se pencher sur ce problème.

Bonne journée

[Banzai64]

Bonjour

A essayer

A améliorer

Code: Tout sélectionner

Option Base 1

Sub macrotest()
'BY Ketamacanna 15/02/11
Dim Mytab1() As Variant, last_ligne1 As Long, last_ligne2 As Long, ws1 As Worksheet, ws2 As Worksheet
Dim Mytab2()
Dim I As Integer
Dim J As Integer

  Set ws1 = Worksheets("Onglet 1")
  Set ws2 = Worksheets("Onglet 2")
  last_ligne1 = ws1.Cells(65000, 1).End(xlUp).Row
  last_ligne2 = ws2.Cells(65000, 1).End(xlUp).Row
 
  If last_ligne1 = 1 Then Exit Sub
 
  Mytab1() = ws1.Range("A2:H" & last_ligne1)
  ReDim Mytab2(1 To 6, 1)
  'borne_dim1 = UBound(Mytab1, 1)
 borne_dim2 = UBound(Mytab1, 2)
 
  For I = 1 To UBound(Mytab1)
    If Mytab1(I, 7) = "OUI" Or Mytab1(I, 8) = "OUI" Then
      For J = 1 To 6
        Mytab2(J, UBound(Mytab2, 2)) = Mytab1(I, J)
      Next J
      ReDim Preserve Mytab2(6, UBound(Mytab2, 2) + 1)
    End If
  Next I
 
  If UBound(Mytab2, 2) = 1 Then Exit Sub
 
  ReDim Mytab1(UBound(Mytab2, 2) - 1, 6)
 
  For I = 1 To UBound(Mytab2, 2) - 1
    For J = 1 To 6
      Mytab1(I, J) = Mytab2(J, I)
    Next J
  Next I
  Range("J2:O6").Resize(UBound(Mytab1), 6) = Mytab1

  Erase Mytab1, Mytab2

End Sub
 

[ketamacanna]

Merci pour ce code. C'est impec. Par contre, j'ai testé sur 10000 lignes, et l'ancien code mettait 1 seconde, avec le nouveau, environ 5. Connais-tu la raison ?


Est-il donc plus judicieux de laisser 65000 ? Cela semble plus rapide ? Tu confirmes?

Cordialement

et encore merci Banzai