Double boucle For - Problème de traitement

Le 04/11/2020 à 16:04

Bonjour à tous,

J'essaie de faire une macro pour réorganiser les résultats d'un formulaire Google Forms. Chaque ligne correspond à un participant et comprends plusieurs entreprises (avec les mêmes infos demandées).

Je souhaite donc déplacer les infos afin d'avoir au final un groupe de colonnes pour les infos des participants et un second groupe de colonnes pour celles des entreprises, cf. schéma ci-dessous :

image

J'ai donc pensé faire une macro avec une première boucle comprennant le balaye vertical (lignes) et un second pour celui horizontal (colonnes). Cependant lorsque je lance la macro, celle-ci ne traite qu'un groupe d'information pour UNE seule entreprise sans passer ni à l'entreprise suivante ni à la ligne suivante (participant)... Je ne comprends pas trop où est le problème ici 

Sub RéorganisationFormulaireRéponses()

Dim ColEtu As Integer

Dim ColEnt As Integer

Dim NBRubrique As Integer

Dim NBEnt As Integer

Dim nbcells As Integer

Dim Lig As Integer

Dim Ent As Integer

Dim BeginEnt As Integer

Dim EndEnt As Integer

ColEtu = Sheets("CTRL rép. Formu").Range("ColEtudiant")

ColEnt = Sheets("CTRL rép. Formu").Range("ColEntre.")

NBRubrique = Sheets("CTRL rép. Formu").Range("NB.Rubriques")

NBEnt = Sheets("CTRL rép. Formu").Range("NB.Entreprises")

nbcells = Application.WorksheetFunction.CountA(Sheets("Réponses au formulaire").Range("$A:$A"))

Worksheets("Réponses au formulaire").Select

For Lig = 2 To nbcells

For Ent = 2 To NBEnt

BeginEnt = ColEtu + 1 + (Ent - 1) * ColEnt 'Début Colonne entreprise n

EndEnt = BeginEnt + ColEnt - 1 'Fin Colonne entreprise n

PasteLig = nbcells + 1 'Ligne où coller

PasteCol = ColEtu + 1 'colonne où coller

If Not Application.CountA(Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt))) = 0 Then

Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt)).Copy

Cells(PasteLig, PasteCol).Select

ActiveSheet.Paste

Range(Cells(Lig, 1), Cells(Lig, ColEtu)).Copy

Cells(PasteLig, 1).Select

ActiveSheet.Paste

End If

Next Ent

Next Lig

End Sub

Je vous remercie par avance de votre aide,

à bientôt,

Julien.

6forum.xlsm (29.03 Ko)
Le 04/11/2020 à 17:02

Bonjour,

je me suis perdu dans ton code

autre formulation

Sub RéorganisationFormulaireRéponses()

tbl = Sheets("Réponses au formulaire").Cells(1, 1).CurrentRegion.Value
Dim participant(1 To 4)
Dim entreprise(1 To 12)

' selection et effacement
Sheets("Reformulation").Select
Cells(1, 1).CurrentRegion.Offset(1, 0).ClearContents
ligne = 1

' balayage tableau
For i = 2 To UBound(tbl)
    For k = 1 To 4
        participant(k) = tbl(i, k)
    Next
    For j = 5 To UBound(tbl, 2) Step 12
        If tbl(i, j) <> "" Then
            ligne = ligne + 1
            For k = 1 To 12
                entreprise(k) = tbl(i, k + j - 1)
            Next
            Cells(ligne, 1).Resize(1, 4) = participant
            Cells(ligne, ((j - 5) Mod 12) + 5).Resize(1, 12) = entreprise
        End If
    Next
Next

End Sub
5forum.xlsm (30.15 Ko)
Le 04/11/2020 à 17:52

haha, je comprends
En gros, c'est cette partie qui pose problème, le reste c'est l'attribution des variables :

For Lig = 2 To nbcells

    For Ent = 2 To NBEnt

            BeginEnt = ColEtu + 1 + (Ent - 1) * ColEnt 'Début Colonne entreprise n

            EndEnt = BeginEnt + ColEnt - 1 'Fin Colonne entreprise n

            PasteLig = nbcells + 1 'Ligne où coller

            PasteCol = ColEtu + 1 'colonne où coller

        If Not Application.CountA(Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt))) = 0 Then

            Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt)).Copy

            Cells(PasteLig, PasteCol).Select

            ActiveSheet.Paste

            Range(Cells(Lig, 1), Cells(Lig, ColEtu)).Copy

            Cells(PasteLig, 1).Select

            ActiveSheet.Paste

        End If

    Next Ent

Next Lig

J'aimerais bien savoir ce qui cloche dans mon code

Merci pour ton code, perso je m'y perd pas mais je ne comprends pas tout le code xD chacun ses problèmes

Le 04/11/2020 à 20:46

je pense que dans ton code, tu confonds lig qui est la ligne d'origine avec lig qui est la ligne de destination

sépare en mettant ligO et ligD et surtout, incrémente ligD à chaque fois que Not Application.CountA(Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt))) = 0

Le 04/11/2020 à 22:45

Bah non, je sépare déjà avec Lig (ligne où je copie) et PasteLig (ligne où je colle)

Le 05/11/2020 à 00:24

Bonjour à tous,

PasteLig = nbcells + 1 'Ligne où coller
ne change pas après un collé, tu colles tout au même endroit
eric

Le 05/11/2020 à 08:31

Salut eriiic :)
je n'ai pas bien compris ta réponse je crois

à bientôt,

Julien,

Le 05/11/2020 à 08:41

Pour mettre au point un programme, ajoute des espions ou des debug.print pour savoir comment il se déroule

Si tu fais ceci

                If Not Application.CountA(Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt))) = 0 Then
                    Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt)).Copy
                    Cells(pastelig, PasteCol).Select
                    ActiveSheet.Paste
Debug.Print pastelig
                    Range(Cells(Lig, 1), Cells(Lig, ColEtu)).Copy
                    Cells(pastelig, 1).Select
                    ActiveSheet.Paste
                End If

et Ctrl+G, tu verras apparaitre un 9 constant !

Le 05/11/2020 à 08:48

ton code adapté en tenant compte du commentaire d'Eriiic et du point que je t'avais signalé et qui aurait du te mettre la puce à l'oreille

Steelson a écrit :

incrémente ligD à chaque fois que Not Application.CountA(Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt))) = 0

    pastelig = nbcells
    For Lig = 2 To nbcells
        For Ent = 2 To NBEnt
            BeginEnt = ColEtu + 1 + (Ent - 1) * ColEnt 'Début Colonne entreprise n
            EndEnt = BeginEnt + ColEnt - 1 'Fin Colonne entreprise n
            PasteCol = ColEtu + 1 'colonne où coller

                If Not Application.CountA(Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt))) = 0 Then

                    pastelig = pastelig + 1

                    Range(Cells(Lig, BeginEnt), Cells(Lig, EndEnt)).Copy
                    Cells(pastelig, PasteCol).Select
                    ActiveSheet.Paste

                    Range(Cells(Lig, 1), Cells(Lig, ColEtu)).Copy
                    Cells(pastelig, 1).Select
                    ActiveSheet.Paste
                End If
        Next Ent
    Next Lig
Le 05/11/2020 à 09:14

Bonjour,

je n'ai pas bien compris ta réponse je crois

à chaque fois que tu colles il faut incrémenter ta ligne de collage pour écrire sur la suivante.
En pas à pas (et en mettant des entreprises en plus sur la ligne), tu verras que tu colles au même endroit.
eric

Le 05/11/2020 à 09:31

Haaaaa merci beaucoup à vous deux

Donc c'est juste le placement de mon code ci-dessous qui n'était pas bon, okkkkkkk.

pastelig = pastelig + 1

ton code adapté en tenant compte du commentaire d'Eriiic et du point que je t'avais signalé et qui aurait du te mettre la puce à l'oreille

Effectivement maintenant que j'ai compris c'est évident mais je n'avais pas compris ça comme ça

Encore merci,

Agréable journée à vous

Julien,

Le 05/11/2020 à 11:23

Donc c'est juste le placement de mon code ci-dessous qui n'était pas bon, okkkkkkk.

a regarder sommairement, j'ai l'impression que ce n'est pas tout.
Si c'est une mise à plat des données (3 entreprises sur une ligne x te génère 3 lignes) que tu veux et que tu écris la 2nde entreprise en ligne 3, tu écrases les données de cette ligne.
Si c'est ça, pour moi il faudrait lire toutes les données dans une variable tableau, le parcourir pour remplir un tableau avec un nombre suffisant de lignes x 16 colonne. Puis coller ce nouveau tableau.

Ou bien si tu veux continuer sur ta logique (lire et écrire ligne à ligne n'est pas la plus efficace), il faut écrire le résultat sur autre autre feuille pour ne pas écraser tes données.

Le 05/11/2020 à 11:35

Hello Eriiiic

eriiic a écrit :

Ou bien si tu veux continuer sur ta logique (lire et écrire ligne à ligne n'est pas la plus efficace), il faut écrire le résultat sur autre autre feuille pour ne pas écraser tes données.

Là je cautionne à 100%. Il ne faut jamais détruire les données d'entrée, et il vaut mieux ré-écrire sur un autre onglet Sheets("Reformulation") comme j'ai proposé tout au début.

Le 05/11/2020 à 11:39

D'accord.

Pourquoi ne faut-il jamais écraser les données ? une fois que c'est traiter ce n'est plus utile sauf dans certains cas

Le 05/11/2020 à 11:46

Si tu lis ligne à ligne et qu'une ligne en écris 12, tu perds des données sur les 11 suivantes puisque tu écris dessus

Pour t'aider à comprendre ce que fait un code tu peux le faire en pas à pas avec F8 et espionner tes variables, voir le résultat sur feuille, etc
Apprend à déboguer, c'est comme ça que tu progresseras plus
http://www.commentcamarche.net/contents/1381-debogage

Le 05/11/2020 à 11:48

ou alors tu les ré-écris une deuxième fois en dessous et c'est sans fin

de toute façon c'est plus une question d'intégrité des données et de vérification possible ultérieure

Le 05/11/2020 à 12:16

Ok les gars, je vous remercie pour tous ces détails et conseils. Je vais reprendre ça à tête reposée pour tout comprendre.

Pour t'aider à comprendre ce que fait un code tu peux le faire en pas à pas avec F8 et espionner tes variables, voir le résultat sur feuille, etc

Apprend à déboguer, c'est comme ça que tu progresseras plus

http://www.commentcamarche.net/contents/1381-debogage

Merci pour l'info

Rechercher des sujets similaires à "double boucle probleme traitement"