Microsoft 365 Correction d'un code vba

[AD95]

Bonjour la team,

Tout d'abord, merci d'avance pour votre aide.
Voilà j'ai un problème avec mon code il ne fait pas exactement ce que je veux

Voici mon besoin :

1 ==> A partir de la 12 -ème feuille si colonne A contient le chiffre "0" alors copier toute la ligne
2 ==>Coller les lignes dans la feuille All_Name (Coller à la dernière ligne)
3 ==> Supprimer toutes les colonnes sauf :
Colonne C ==> Classe
Colonne F ==> 1C
Colonne G ==> 2C
Colonne I ==> 4C
Colonne J ==> 5C
Colonne R ==> 3C

4. Si colonne A contient doublon alors supprimer la ligne en doublon (doit rester qu'une valeur unique)

5. Ajouter 2 colonnes et nommer
Entity
Product Line

6. Agencer/Renommer les colonnes
Colonne A ==> ID
Colonne B ==> Nom
Colonne C ==> Prenom
Colonne D ==> Entity
Colonne E ==> Contract
Colonne F ==> Product Line
Colonne G ==> Manager
Colonne R ==> Start Date


Le problème c'est qu'il me copie pas que la ligne qui contient "0" et supprime pas que la ligne en doublon je vois pas où se trouve l'erreur dans le code

 

[mapomme]

Bonsoir @ad95 ,

J'ai un petit sentiment de malaise :

• vous parlez de "mon code". Ne serait-ce pas plutôt celui de patrickT ici sur XLP ?
• sur XLP, vous êtes l'auteur d'un fil sur lequel patrickT a consacré beaucoup de temps à vous concocter une solution. Pourquoi aller faire "corriger" ce code sur un autre forum dans une autre discussion ?
• j'espère que le membre de XLD "patricktoulon" ne tombera pas sur ce fil, car il risque de nous faire une violente syncope .

 

[AD95]

Bonsoir @ad95 ,

J'ai un petit sentiment de malaise :

• vous parlez de "mon code". Ne serait-ce pas plutôt celui de patrickT ici sur XLP ?
• sur XLP, vous êtes l'auteur d'un fil sur lequel patrickT a consacré beaucoup de temps à vous concocter une solution. Pourquoi aller faire "corriger" ce code sur un autre forum dans une autre discussion ?
• j'espère que le membre de XLD "patricktoulon" ne tombera pas sur ce fil, car il risque de nous faire une violente syncope .

@mapomme si c'est bien ça mais j'ai pas trop envie de l'embêter justement il a passer du temps dessus et je lui en remercie infiniment mais j'arrive pas à trouver le problème de son côté ça fonctionne bien mais pas chez moi je veux pas continuer à l'agacer je l'ai déjà trop soulé .

(j'ai mis mon code car j'ai fait un copier/coller car j'avais mon code à la base mais il était très lent et le but était justement de le modifier pour le rendre plus rapide. Son code est riche et j'essaie de le comprendre justement

 

[mapomme]

Re,

Dans ce cas :

Avec votre explication, patrickT (sur XLP) ou patricktoulon (sur XLD) pourrait éventuellement comprendre votre démarche. Quand on explique, on est amené à comprendre, voire à excuser.

Mais un laconique "il ne fait pas exactement ce que je veux" sans dire explicitement ce qu'il ne fait pas ou ce qu'il ne fait pas comme vous le voudriez n'est d'aucune utilité pour vous répondre. Il faut aller dans les détails.

 

[patricktoulon]

re
bonsoir Ad95
mon code marche parfaitement bien avec d'autres feuilles que j'ai faite moi même
si des cellules avec 1 sont prises quand même ca viens de tes feuilles qui affiche ce qui n'est pas

d'autre part le crossposting est mal vu
comprends bien que si quelqu'un se casse la tête pour toi et que tu va chercher bonheur ailleurs
et que si solution trouvé ailleurs ton post sur XLP restera non résolu
ou inversement
et maintenant à ce que je vois il y a une colonne supplementaire la R
il faudrait peut $etre donner tout les élements d'un coup

 

[AD95]

Re patricktoulon,

oui bien sûr je t'ai envoyé un message de remerciement justement et je voulais pas abusé de ton temps, c'est pour avoir un œil nouveau que je demande ici car comme je t'ai dit je trouve pas mon erreur sur la feuille j'ai passé la nuit à chercher et tester alors que chez toi ça fonctionne (c'est ça qui me rend dingue )le code est excellent car très rapide contrairement au mien.
Je t'ai envoyé un message pour t'informer que je vais me renseigner droite à gauche pour voir et si je trouve mon problème je l'aurai partagé pour t'en informé aussi le but est de partager aussi pour les autres si ça peux servir donc je l'aurai fait et mis en résolu par la suite (c'est pour ça que je l'ai pas encore fait)

 

[patricktoulon]

la raison je te l'ai donné
c'est tes feuilles qui partent en vrille
il y a "1" dans la cellule mais quoi que je fasse vba l'identifie comme "0"

if val(sh.cells(lig,"A")) =0 and sh.cells(lig,"A")<>"" then

prend quand même la ligne avec "1"

if trim(sh.cells(lig,1).text)="0"

prend quand même la ligne avec "1"

d'autant plus qu'il n'y a pas que ces lignes qui ont 1
alors pose toi la question et surtout dans le bon sens

la question qui va allumer tout les ampoules dans ta tête
pourquoi certaines lignes avec "1" passent Alors d'autres sont bien exeptées

si je te dis que tes feuilles sont pourries c'est quelles sont pourries !!
j'ai passé des heures avant d'abandonner et d'en conclure que ca ne pouvait être que tes feuilles qui flipent

 

[TooFatBoy]

Bonjour,

oui bien sûr je t'ai envoyé un message de remerciement justement et je voulais pas abusé de ton temps, c'est pour avoir un œil nouveau que je demande ici car comme je t'ai dit je trouve pas mon erreur sur la feuille j'ai passé la nuit à chercher et tester alors que chez toi ça fonctionne (c'est ça qui me rend dingue )le code est excellent car très rapide contrairement au mien.

Chez moi aussi ça semble ne pas fonctionne.

J'ai corrigé trois choses et ça semble mieux fonctionner, mais je ne suis pas sûr, donc c'est à vérifier.

 

[TooFatBoy]

d'autant plus qu'il n'y a pas que ces lignes qui ont 1
alors pose toi la question et surtout dans le bon sens

la question qui va allumer tout les ampoules dans ta tête
pourquoi certaines lignes avec "1" passent Alors d'autres sont bien exeptées

si je te dis que tes feuilles sont pourries c'est quelles sont pourries !!
j'ai passé des heures avant d'abandonner et d'en conclure que ca ne pouvait être que tes feuilles qui flipent

Est-ce que ce n'es pas plutôt parce que tu te décales d'une ligne en commençant les tests à partir de la ligne n° 1 de chaque feuille, qui est en fait la ligne d'en-tête du tableau ?

Si ce n'est pas ça, patapay, je n'ai pas passé des heures à chercher, mais seulement 5 minutes.

 

[patricktoulon]

bonsoir garçon trop gros(pas pire que moi)
je décale rien

 For LiG = 1 To SH.Cells(Rows.Count, 2).End(xlUp).Row                                                          'boucle de la ligne 1 à la dernière
            If Val(SH.Cells(LiG, "A")) = 0 And SH.Cells(LiG, "A") <> "" Then                                          'si la condition est remplie
                A = A + 1: ReDim Preserve arrligne(1 To A): arrligne(A) = LiG                                         'on incrémente la matrice de ligne et on y intègre l'index de ligne "lig"
            End If
        Next

je teste la ligne 1 je pourrais m'en passer mais je ne decale rien
la variable A c'est l'index du tableau arrlig qui n'a rien a voir avec le numero de ligne
donc non je décale pas

de toute facon j'ai testé avec des feuilles que j'ai fais moi même avec des noms et la colonne A avec des chiffres de 0 à 9 et je ne récupère rien d'autre que les zero
conclusion je le redis ces feuilles sont pourries
point barre

 

[TooFatBoy]

je teste la ligne 1 je pourrais m'en passer mais je ne decale rien
la variable A c'est l'index du tableau arrlig qui n'a rien a voir avec le numero de ligne
donc non je décale pas

OK, alors au temps pour moi.

 

[TooFatBoy]

J'ai corrigé trois choses et ça semble mieux fonctionner, mais je ne suis pas sûr, donc c'est à vérifier.

Du coup je viens de vérifier, et avec les 3 corrections à cause du décalage, ça fonctionne.

 

[patricktoulon]

ho puré de puré de puré de puré de puré
je viens de m'en rendre compte moi aussi
l'erreur est simple

Set RnG = SH.Range("A 2/1 :AA" & SH.Cells(Rows.Count, 2).End(xlUp).Row - 1) 'on prend toute la

Option Explicit
Sub testX()
    Dim colonne, SH, A&, MsG$, LiG&, RnG, TotaL&, TabLresulT, I&
    colonne = Array( 2, 3, 6, 7, 1, 10, 1, 9)   'matrice de colonne
    Sheets("All_Name").Cells.Clear                                                                                      ' vide la feuille All_Name
    DoEvents
    Application.ScreenUpdating = False
    For I = 13 To Sheets.Count                                                                                         'boucle de 13 à sheets.count
        ReDim arrligne(1 To 1)                                                                                         'on redim la matrice de ligne a chaque feuille
        Set SH = Sheets(I)
        A = 0
      
        For LiG = 1 To SH.Cells(Rows.Count, 2).End(xlUp).Row                                                          'boucle de la ligne 1 à la dernière
            If Val(SH.Cells(LiG, "A")) = 0 And SH.Cells(LiG, "A") <> "" Then                                          'si la condition est remplie
                A = A + 1: ReDim Preserve arrligne(1 To A): arrligne(A) = LiG                                         'on incrémente la matrice de ligne et on y intègre l'index de ligne "lig"
           If LiG < 20 Then Debug.Print "ligne " & LiG & "   " & SH.Cells(LiG, 1) & "---" & SH.Cells(LiG, 2)
        
           End If
        Next
        MsG = MsG & SH.Name & " copie= " & A & " ligne(s)" & vbLf                                                     'on ajoute au texte du message
        TotaL = TotaL + A                                                                                             'on calcule le total de lignes
        Set RnG = SH.Range("A1:AA" & SH.Cells(Rows.Count, 2).End(xlUp).Row - 1)                                       'on prend toute la plage
        TabLresulT = Application.Index(RnG.Value, Application.Transpose(arrligne), colonne)                           'récupération du tableau selon la matrice de ligne et colonne
        With Sheets("All_Name").Cells(Rows.Count, 1).End(xlUp).Offset(1)
            .Resize(UBound(arrligne), UBound(colonne) + 1) = TabLresulT                                               'injection du tableau dans la ligne dispo a partir d'en bas
        End With
    Next
    With Sheets("All_Name")
        'suppression des doublons
        .Range("$A$1:$AA$" & .Cells(Rows.Count, "a").End(xlUp).Row).RemoveDuplicates Columns:=1, Header:=xlNo         'suppression des doublons
        TotaL = .Cells(Rows.Count, "B").End(xlUp).Row                                                                 'total des ligne récupérées

        .Columns(1).Delete
        'Suppression des colonnes non utilisées
        .Range("d:d,f:f").Clear                                                                                       'vidage des colonne que l'on a récupéré et qui sont les colonnes ajoutées


        'Nommer les Entêtes
        .Range("A1").Resize(, 7) = Array("ID", "Nom", "Prenom", "Entity", "contract", "Product line", "manager")    'Entêtes de colonne




        'design du tableau
        '***********************************************************
        'soit en range
        ' With .Range("A1:H" & .Cells(Rows.Count, 1).End(xlUp).Row)
        '    With .Rows(1)
        '   .Interior.Color = RGB(0, 0, 255)    ' Bleu
        '       .Font.Color = RGB(255, 255, 255)    ' Blanc
        '      .Font.Bold = True
        '  End With
        '  .HorizontalAlignment = xlCenter
        '  .VerticalAlignment = xlCenter

        '.Borders(xlEdgeLeft).LineStyle = xlContinuous
        ' .Borders(xlEdgeTop).LineStyle = xlContinuous
        '.Borders(xlEdgeRight).LineStyle = xlContinuous
        ' .Borders(xlEdgeBottom).LineStyle = xlContinuous
        '.Borders(xlInsideVertical).LineStyle = xlContinuous
        '.Borders(xlInsideHorizontal).LineStyle = xlContinuous
        ' End With
        '*********************************************************

        'ou tout simplement en listobject(tableau structuré)

        .ListObjects.Add(xlSrcRange, .Range("A1:G" & .Cells(Rows.Count, 1).End(xlUp).Row), , xlYes).Name = "Tableau1"
        '*************************************************
        [A1].Select
.Shapes("bouton").Left = 550
     End With


    MsgBox MsG & vbCrLf & "Pour un total de " & TotaL & " lignes" & vbCrLf & " en ayant supprimé les doublons "
    Application.ScreenUpdating = True
End Sub

donc autant pour moi méacoulpa je me suis énervé pour rien
donc @AD95 tu a droit à toutes mes excuses c'est bien une petite erreur de ma part

puré de puré de puré de puré !!!! un 2 à la place d'un 1
et je tourne comme un fou depuis hier

et travail fini ca donne ça

 

[AD95]

Bonjour la team,

@TooFatBoy @patricktoulon Mille merci ça marche nikel enfin je devenais dingue à pas trouver l'erreur chez moi @patricktoulon y a pas à s'excuser déjà que tu m'aide je suis trop novice encore pour tout capter j'ai encore du boulot pour arriver à votre niveau.

Un grand grand merci à vous je vais pouvoir dormir ce soir !!!!!!!!!!!!!!


Si je peux me permettre pour ne pas galérer dans la maintenance, qu'es que je doit modifier si jamais mon besoin évolue (car il va évoluer dans le temps avec 1 modification) ?

je vais rajouter 2 lignes (donc début des données en lignes 4) où je doit apporter une modification

Comme ceci :

J'ai fait le test sur mon fichier mais il prend la 1ère ligne comment lui dire de commencer par la 4ème ligne ?

 

[AD95]

Voici la réponse de patricktoulon:

Option Explicit
Sub testX()
    Dim colonne, SH, A&, MsG$, LiG&, RnG, TotaL&, TabLresulT, I&, plus
    colonne = Array(2, 3, 6, 7, 1, 10, 1, 9)    'matrice de colonne
    With Sheets("All_Name"): .Range("A5:AA" & .Cells(Rows.Count, 1).End(xlUp).Offset(1).Row).Clear: End With                                                                                   ' vide la feuille All_Name
    DoEvents
    Application.ScreenUpdating = False
    For I = 13 To Sheets.Count                                                                                         'boucle de 13 à sheets.count
        ReDim arrligne(1 To 1)                                                                                         'on redim la matrice de ligne a chaque feuille
        Set SH = Sheets(I)
        A = 0

        For LiG = 4 To SH.Cells(Rows.Count, 2).End(xlUp).Row                                                          'boucle de la ligne 1 à la dernière
            If Val(SH.Cells(LiG, "A")) = 0 And SH.Cells(LiG, "A") <> "" Then                                          'si la condition est remplie
                A = A + 1: ReDim Preserve arrligne(1 To A): arrligne(A) = LiG                                         'on incrémente la matrice de ligne et on y intègre l'index de ligne "lig"
            End If
        Next
        MsG = MsG & SH.Name & " copie= " & A & " ligne(s)" & vbLf                                                     'on ajoute au texte du message
        TotaL = TotaL + A                                                                                             'on calcule le total de lignes
        Set RnG = SH.Range("A1:AA" & SH.Cells(Rows.Count, 2).End(xlUp).Row - 1)                                       'on prend toute la plage
        TabLresulT = Application.Index(RnG.Value, Application.Transpose(arrligne), colonne)                           'récupération du tableau selon la matrice de ligne et colonne
        If I = 13 Then plus = 0 Else plus = 1
        With Sheets("All_Name").Cells(Rows.Count, 1).End(xlUp).Offset(1 + plus)
            .Resize(UBound(arrligne), UBound(colonne) + 1) = TabLresulT                                               'injection du tableau dans la ligne dispo a partir d'en bas
        End With
    Next
     With Sheets("All_Name")
        'suppression des doublons
        .Range("A:AA").RemoveDuplicates Columns:=1, Header:=xlYes          'suppression des doublons
        TotaL = .Cells(Rows.Count, "B").End(xlUp).Row                                                                 'total des ligne récupérées

        .Columns(1).Delete
        'Suppression des colonnes non utilisées
        .Range("d:d,f:f").Clear                                                                                       'vidage des colonne que l'on a récupéré et qui sont les colonnes ajoutées

        'Nommer les Entêtes
        .Range("A1").Resize(, 7) = Array("ID", "Nom", "Prenom", "Entity", "contract", "Product line", "manager")    'Entêtes de colonne

        .ListObjects.Add(xlSrcRange, .Range("A1:G" & .Cells(Rows.Count, 1).End(xlUp).Row), , xlYes).Name = "Tableau1"
        '*************************************************
        ' .Rows("1:3").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        With ActiveWindow: .SplitColumn = 0: .SplitRow = 1: .FreezePanes = True: End With
        [A1].Select
        With .Shapes("bouton"): .Left = 550: .Top = 100: End With

        '*********************************************************************************

    End With

    MsgBox MsG & vbCrLf & "Pour un total de " & TotaL & " lignes" & vbCrLf & " en ayant supprimé les doublons "
    Application.ScreenUpdating = True
End Sub

Merci pour ton retour. J'ai fini mes tests voici le résultat

Mon code :


Ton code Code :


Clairement y ' a pas photo ton code est une aussi rapide que l'éclaire

Désolé encore pour XLD j'ai vue ta petite note


mais je trouvais pas l'erreur chez moi alors que chez toi ça fonctionné il me fallait un œil nouveau pour m'éclairer .

Tout ça à cause d'un 2 à la place du 1 je suis pas près de l'oublier

@patricktoulon @TooFatBoy @mapomme Merci merci infiniment pour votre aide et votre expertise !!!!!!!!!!


Bonne journée à tous !!!!!!!!!!!!!!!