Macro qui ne fonctionne pas

Le 25/09/2020 à 16:50

Bonjour à tous,

Suite à mes différents messages ces derniers jours, je reviens solliciter votre aide une nouvelle fois car je pensais avoir terminé ma macro mais finalement elle ne fonctionne pas et je bloque dessus depuis presque 2 jours...

Je reprend depuis le début, je souhaite créer une Macro que j'intégrerais au ruban afin de copier/coller des lignes d'un tableau présent en page1 vers une page2 en fonction d'un mot clef présent en colonne 3 et si cette ligne comporte des cellules vides à certains endroits...

J'ai donc créé cette macro que j'ai testé sur ma première base comprenant 300 lignes pour 38 colonnes et ça marche nickel !!

Jusque là tout va bien, j'ai donc ajouté cette macro dans le ruban, cependant lorsque j'adapte cette macro sur ma deuxième base composée d'environ 1200 lignes pour 62 colonnes, aucune ligne n'est collée en page2... Cette deuxième base est composée de la même manière que la première sauf que le mot clef est différent.

Je me doute que ma macro ne soit pas très optimisée mais étant débutant sur VBA, je trouvais cette méthode assez intuitive et simple à comprendre...

Je vous colle ma macro à la suite en essayant de vous expliquer ce que je fais:

Sub Macro_donnees()

Sheets("donnees").Name = "Feuil1" ' je renomme la page1 de mon fichier

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Feuil2" ' j'ajoute une page2 que je nomme "Feuil2"

Sheets("Feuil1").Select    ' sur ce premier bloc, je copie/colle les noms des variables présent en ligne 6 de ma page1 en ligne 1 de ma page2
Rows("6:6").Select
Selection.Copy
Sheets("Feuil2").Select
Rows("1:1").Select
ActiveSheet.Paste

Dim derniere_ligne As Long
Dim ligne_en_cours As Long
Dim f As Worksheet, tablo, tabloR()
Dim i&, j&, k&
Dim mot_clef As String

mot_clef = UCase("à définir") ' je définie le mot clef présent en colonne 3
derniere_ligne = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row

For lig = derniere_ligne To 7 Step -1  ' sur ce bloc, je calcule la multiplication de la longueur des chaines de caractères présentes dans les cellules dont je souhaite savoir si elles sont vides, dans le cas où une cellule serait vide, le résultat renvoyé serait 0
If UCase(Sheets("Feuil1").Cells(lig, 3)) = UCase(mot_clef) Then
Blanc = Len(Cells(lig, 7)) * Len(Cells(lig, 10)) * Len(Cells(lig, 13)) * Len(Cells(lig, 16)) * Len(Cells(lig, 19)) * Len(Cells(lig, 22)) * Len(Cells(lig, 25)) * Len(Cells(lig, 28)) * Len(Cells(lig, 31)) * Len(Cells(lig, 34)) * Len(Cells(lig, 37)) * Len(Cells(lig, 40)) * Len(Cells(lig, 43)) * Len(Cells(lig, 46)) * Len(Cells(lig, 49)) * Len(Cells(lig, 52)) * Len(Cells(lig, 55)) * Len(Cells(lig, 58)) * Len(Cells(lig, 61))
If Blanc = 0 Then Cells(lig, 64).Value = 1 ' si une cellule est vide, alors je met un 1 dans la colonne 64 de la ligne correspondante
End If
Next

Set f = Sheets("Feuil1")  ' ce bloc permet de copier/coller les lignes ayant un 1 en colonne 64 et donc une cellule vide au minimum
tablo = f.Range("A1:BL" & f.Range("A" & Rows.Count).End(xlUp).Row)
k = 0
For i = 7 To UBound(tablo, 1)
If tablo(i, 64) = 1 Then
    ReDim Preserve tabloR(1 To 64, 1 To k + 1)
        For j = 1 To 64
            tabloR(j, 1 + k) = tablo(i, j)
Next j
k = k + 1
End If
Next i

Sheets(2).Range("A1").CurrentRegion.Offset(1, 0).ClearContents
On Error Resume Next
Sheets(2).Range("A2").Resize(UBound(tabloR, 2), 64) = Application.Transpose(tabloR)
Erase tabloR

Sheets("Feuil2").Select  ' puis je redimensionne les cellules de la page2
Cells.Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit

Worksheets("Feuil1").Range("BL1:BL65536").Delete shift:=xlUp '  enfin je supprime les colonnes 64 des deux pages
Worksheets("Feuil2").Range("BL1:BL65536").Delete shift:=xlUp

End Sub

J'ai essayé d'être le plus clair possible, n'hésitez pas si vous avez des questions, je vous remercie énormément pour votre aide par avance

Le 25/09/2020 à 20:21

Hello,

Petite question ==> Est ce toi qui a codé cette partie ou tu as pris ce bout de code sur le forum ?

tablo = f.Range("A1:BL" & f.Range("A" & Rows.Count).End(xlUp).Row)
k = 0
For i = 7 To UBound(tablo, 1)
If tablo(i, 64) = 1 Then
    ReDim Preserve tabloR(1 To 64, 1 To k + 1)
        For j = 1 To 64
            tabloR(j, 1 + k) = tablo(i, j)
Next j
k = k + 1
End If
Next i

Je te demande ça car l'utilisation des tableaux ce n'est pas la première chose que l'on apprend quand on est débutant ...

Selon moi, quand on débute, il vaut mieux commencer petit, par des choses simples, certes pas optimisées mais les choses viendront en temps et en heures venues...

Tu devrais commencer par faire du :

.Select
.Copy
.Paste

Quand ça sera maitrisé tu pourras attaquer les tableaux

Je pense que l'erreur vient de cette partie justement.

Il me faudrait un fichier exemple pour que je te donne la réponse.

R@G

Le 26/09/2020 à 12:18

Bonjour R@g !

En effet, j'ai récupéré ce code sur le forum, à vrai dire je patauge un peu avec cette macro...

J'ai créé un fichier exemple qui peut paraitre "bête" mais il reprend vraiment l'esprit du fichier que je traite en entreprise, je colle également la macro que j'ai utilisé en dessous (elle est aussi dans le fichier), le mot_clef est donc "Paris":

Sub Macro_donnees()

Sheets("donnees").Name = "Feuil1"

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Feuil2"

Sheets("Feuil1").Select
Rows("6:6").Select
Selection.Copy
Sheets("Feuil2").Select
Rows("1:1").Select
ActiveSheet.Paste

Dim derniere_ligne As Long
Dim ligne_en_cours As Long
Dim f As Worksheet, tablo, tabloR()
Dim i&, j&, k&
Dim mot_clef As String

mot_clef = UCase("Paris")
derniere_ligne = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row

For lig = derniere_ligne To 7 Step -1
If UCase(Sheets("Feuil1").Cells(lig, 3)) = UCase(mot_clef) Then
Blanc = Len(Cells(lig, 7)) * Len(Cells(lig, 10)) * Len(Cells(lig, 13)) * Len(Cells(lig, 16)) * Len(Cells(lig, 19)) * Len(Cells(lig, 22)) * Len(Cells(lig, 25)) * Len(Cells(lig, 28)) * Len(Cells(lig, 31)) * Len(Cells(lig, 34)) * Len(Cells(lig, 37)) * Len(Cells(lig, 40)) * Len(Cells(lig, 43)) * Len(Cells(lig, 46)) * Len(Cells(lig, 49)) * Len(Cells(lig, 52)) * Len(Cells(lig, 55)) * Len(Cells(lig, 58)) * Len(Cells(lig, 61))
If Blanc = 0 Then Cells(lig, 64).Value = 1
End If
Next

Set f = Sheets("Feuil1")
tablo = f.Range("A1:BL" & f.Range("A" & Rows.Count).End(xlUp).Row)

k = 0
For i = 7 To UBound(tablo, 1)
If tablo(i, 64) = 1 Then
    ReDim Preserve tabloR(1 To 64, 1 To k + 1)
        For j = 1 To 64
            tabloR(j, 1 + k) = tablo(i, j)
Next j
k = k + 1
End If
Next i

Sheets(2).Range("A1").CurrentRegion.Offset(1, 0).ClearContents
On Error Resume Next
Sheets(2).Range("A2").Resize(UBound(tabloR, 2), 64) = Application.Transpose(tabloR)
Erase tabloR

Sheets("Feuil2").Select
Cells.Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit

Worksheets("Feuil1").Range("BL1:BL65536").Delete shift:=xlUp
Worksheets("Feuil2").Range("BL1:BL65536").Delete shift:=xlUp

End Sub

Je te remercie énormément pour ton aide et j'espère que tu pourras trouver le problème

4test-macro.xlsm (272.23 Ko)
Le 26/09/2020 à 13:10
Bonjour, Oui c'est vrai, le travail avec des tableaux n'est pas le plus simple, mais qi tu as beaucoup de données c'est utile pour aller vite ... l'idéal serait de faire les 2 et comparer.
Le 26/09/2020 à 13:13

Hello,

Voici le code :

Sub Macro_donnees()

Dim derniere_ligne As Long
Dim i&, k&
Dim mot_clef As String

Sheets("donnees").Name = "Feuil1"
Sheets.Add(after:=Sheets(Sheets.Count)).Name = "Feuil2"
Sheets("Feuil1").Select
Rows("6:6").Select
Selection.Copy
Sheets("Feuil2").Select
Rows("1:1").Select
ActiveSheet.Paste
Sheets("Feuil1").Select

mot_clef = "PARIS"
derniere_ligne = Sheets("Feuil1").Cells(Rows.Count, 1).End(xlUp).Row
k = 2

For lig = 7 To derniere_ligne
    If UCase(Sheets("Feuil1").Cells(lig, 3)) = mot_clef Then
        If Cells(lig, 7) = "" Or Cells(lig, 10) = "" Or Cells(lig, 13) = "" Or Cells(lig, 16) = "" Or Cells(lig, 19) = "" Or Cells(lig, 22) = "" _
            Or Cells(lig, 25) = "" Or Cells(lig, 28) = "" Or Cells(lig, 31) = "" Or Cells(lig, 34) = "" Or Cells(lig, 37) = "" Or Cells(lig, 40) = "" _
            Or Cells(lig, 43) = "" Or Cells(lig, 46) = "" Or Cells(lig, 49) = "" Or Cells(lig, 52) = "" Or Cells(lig, 55) = "" Or Cells(lig, 58) = "" _
            Or Cells(lig, 61) = "" Then
                Sheets("Feuil1").Range("A" & lig & ":BL" & lig).Copy Sheets("Feuil2").Range("A" & k & ":BL" & k)
                k = k + 1
        End If
    End If
Next lig

Sheets("Feuil2").Select
Cells.Select
Selection.Columns.AutoFit
Selection.Rows.AutoFit

End Sub

Un code facile à comprendre surtout dans quelques mois quand tu voudras potentiellement faire évoluer.

Les puristes ne vont pas aimer ce code mais il fait le boulot

J'ai volontairement pas mis de commentaires pour que tu puisses t'imprégner du code et te l'approprier

R@g

Le 26/09/2020 à 13:16

Hello Steelson,

Oui c'est clair que les tableaux en terme de rapidité c'est bien mieux que du select ; copy ; paste

R@g

Le 26/09/2020 à 13:20

Autre solution en une seule ligne de programme

Sub recopier()
    Sheets("donnees").Range("A6:BJ1194").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("BL6:BL7"), CopyToRange:=Range("A6:BJ6"), Unique:=False
End Sub
6test-macro.xlsm (262.65 Ko)
Le 27/09/2020 à 20:13

Bonjour à tous,

Je vous remercie pour vos macros, j'ai plutôt opté pour le code de R@g car au moins je comprend ce que je fait et c'est plus proche de ce que j'ai l'habitude de faire sur les autres logiciels... Je ne pense pas encore avoir le niveau d'utiliser la méthode de Steelson bien que ça soit vraiment plus court...

Au final, tout fonctionne quand même, je vous en remercie énormément

Rechercher des sujets similaires à "macro qui fonctionne pas"