Résolu Copier des lignes avec certaines valeurs d'un onglet à l'autre

Neruda

XLDnaute Nouveau
Bonjour,

J'ai sur un onglet une liste de critères.
Le numéro du critère en A1
Le texte du critère en B1
Le statut du critère en C1 (il peut être "C" ou "NC")

Comment récupérer seulement ceux qui sont NC,
copier dans un autre onglet seulement les cellules A et B de chaque critère NC,
(en insérant le nombre de lignes nécessaires) ?

Si quelqu'un peut m'aider svp

Merci
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonsoir Neruda,
Un essai en PJ.
J'ai ajouté deux choses :
1- L'archivage des NC sont datées
2- Je supprime les NC de la base.
VB:
Sub Archive()
DerLig = Range("A65500").End(xlUp).Row
For i = 2 To DerLig
    If Cells(i, "C") = "NC" Then
        LigNC = 1 + Sheets("NC").Range("A65500").End(xlUp).Row
        Sheets("NC").Cells(LigNC, 1) = Now          ' Insere date d'archivage
        Sheets("NC").Cells(LigNC, 2) = Cells(i, 1)  ' N°
        Sheets("NC").Cells(LigNC, 3) = Cells(i, 2)  ' Critère
        Rows(Cells(i, 1).Row).Delete shift:=xlUp    ' Supprime la ligne
    End If
Next i
End Sub
 

Fichiers joints

Neruda

XLDnaute Nouveau
Bonjour,

Le script est parfait, merci.
Il copie les lignes à la fin de ma feuille de destination.
Mais est-il possible de les insérer à partir de la ligne 22 (sans effacer ce qui vient après la ligne 22, c'est-à-dire en ajoutant des lignes.

Et que signifie "B65500" svp ?

Je l'ai juste un peu modifié car je dois conserver les critères sur l'autre feuille et je n'ai pas besoin de la date :
VB:
Option VBASupport 1
Sub Archive()
DerLig = Range("B65500").End(xlUp).Row
For i = 2 To DerLig
    If Cells(i, "D") = "NC" Then
        LigNC = 1 + Sheets("Declaration").Range("B65500").End(xlUp).Row
        Sheets("Declaration").Cells(LigNC, 1) = Cells(i, 2)  ' N°
        Sheets("Declaration").Cells(LigNC, 2) = Cells(i, 3)  ' Critère
    End If
Next i
End Sub
Merci
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
La ligne :
VB:
LigNC = 1 + Sheets("Declaration").Range("B65500").End(xlUp).Row
va permettre de les insérer dans les deux premières lignes vides rencontrées.
Donc si les lignes sont occupées jusqu'en 22 il insèrera après.
 

Neruda

XLDnaute Nouveau
Cela les ajoute après la dernière ligne écrite en bas de la feuille,
j'ai pourtant laissé 2 lignes vides après la ligne 22,
je vais essayer de trouver mais n'hésitez pas si vous avez une idée,

Merci encore
 
Dernière édition:

Neruda

XLDnaute Nouveau
Effectivement il y a des lignes pleines après la ligne 24.
Et j'aurais voulu insérer les critères que je récupère entre la ligne 22 et la ligne 24 en créant de nouvelles lignes pour ne pas écraser les lignes suivantes.
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Si c'est uniquement en ligne 22 que vous voulez insérer alors utilisez :
VB:
Rows("22:22").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
et supprimer la ligne
Code:
LigNC = 1 + Sheets("Declaration").Range("B65500").End(xlUp).Row
cela pourrait donner :
Code:
Sub Archive()
DerLig = Range("B65500").End(xlUp).Row
For i = 2 To DerLig
    If Cells(i, "D") = "NC" Then
        Rows("22:22").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
        Sheets("Declaration").Cells(22, 1) = Cells(i, 2)  ' N°
        Sheets("Declaration").Cells(22, 2) = Cells(i, 3)  ' Critère
    End If
Next i
End Sub
Si tant est que cela soit ce que vous voulez faire.
 

Neruda

XLDnaute Nouveau
en fait le code précédent ne me copiait qu'une ligne sur la ligne 22 de ma page de destination,
en revanche il créait des nouvelles lignes vides à partir de la page 22 de la feuille d'origine,
je vais bien regarder votre nouveau fichier,
Merci
 

Neruda

XLDnaute Nouveau
Bonjour,

Merci pour le script, il convient tout à fait et insère bien les données à partir de la ligne 22 en ajoutant de nouvelles lignes.
Mais il remonte les critères en inversant leur ordre de classement, pourriez-vous m'indiquer comment rétablir l'ordre d'origine svp ?
J'aimerais aussi ajouter la date de génération de cette liste avec ce format : Dimanche 11 octobre en cellule C29, mais je ne vois pas comment faire et surtout comme cette cellule va changer de numéro de ligne car les critères sont ajoutés à partir de la ligne 22 et vont donc décaler tout le contenu suivant.

Merci

VB:
Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Sub Archive()
DerLig = Range("B65500").End(xlUp).Row
For i = 2 To DerLig
    If Sheets("Criteres").Cells(i, "D") = "NC" Then
        With Sheets("Declaration")
            .Rows("22:22").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            .Cells(22, 1) = Sheets("Criteres").Cells(i, 2)  ' N°
            .Cells(22, 2) = Sheets("Criteres").Cells(i, 3)  ' Critère
        End With
    End If
Next i
End Sub
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Bonjour,
Evidemment, si à chaque fois vous insérez en ligne 22, le résultat sera en ordre inverse.
Dans ce cas il faut incrémenter le N° ligne où insérer :
VB:
Rem Attribute VBA_ModuleType=VBAModule
Option VBASupport 1
Sub Archive()
DerLig = Range("B65500").End(xlUp).Row
For i = 2 To DerLig
    If Sheets("Criteres").Cells(i, "D") = "NC" Then
        With Sheets("Declaration")
            Ligne = 20 + i ' Ligne 22 + i - 2 car i commence à 2
            .Rows(Ligne).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
            .Cells(Ligne, 1) = Sheets("Criteres").Cells(i, 2)  ' N°
            .Cells(Ligne, 2) = Sheets("Criteres").Cells(i, 3)  ' Critère
        End With
    End If
Next i
 Sheets("Declaration").Range("C29") = Format(Date, "dddd dd mmmm yyyy")
End Sub
J'ai mis la date en C29 mais n'ai pas tout compris au pourquoi du comment, à vous de modifier en conséquence.
 

Neruda

XLDnaute Nouveau
Bonjour,

Avec cette modification j'ai bien l'ordre qui est rétabli, mais au lieu de bien les insérer en créant les lignes et en décalant les contenus suivants comme précédemment, les lignes s'ajoutent de façon aléatoire au sein du contenu suivant sans les remplacer. En décalant aussi les contenus mais les critères ne se suivent plus et sont noyés dans les contenus suivants.

Merci
 

Neruda

XLDnaute Nouveau
J'ai refait un nouveau fichier à partir du fichier original vierge,
J'ai mis la dernière version du code de la macro qui remontait bien les éléments où il fallait mais dans l'ordre inverse.
Dans un deuxième temps je voulais aller chercher dans toutes les pages (de P01 à P20) dans toutes les colonnes H le texte de chaque cellule rencontré et le copier dans la partie déclaration en m'aidant de ce code. Mais je vois déjà plusieurs difficultés.
  • la recherche doit se faire sur plusieurs feuilles
  • il peut y avoir 20 feuilles à fouiller maxi, mais on peut en supprimer si moins de pages, donc il peut y en avoir moins
  • il sera difficile d'indiquer où les ajouter sur la feuille déclaration car l'emplacement initial va être modifié après l'ajout des critères
Merci encore pour l'aide, j'ai LibreOffice Calc et pas Excel, je ne sais pas si ça a un impact, j'ai d'ailleurs dû le zipper pour que le format de fichier .ods soit accepté
 
Dernière édition:

Neruda

XLDnaute Nouveau
D'ailleurs ma condition pour afficher un mot selon le niveau ne marche plus, ou n'a jamais marché sur la feuille déclaration.
si 100 % alors Conformité, si >ou = à 50 % alors Conformité partielle, si < à 50 % alors Non-conformité
Merci
 

sylvanu

XLDnaute Barbatruc
Supporter XLD
Re bonjour,
Un essai en PJ.
Je ne suis pas sur que XL et LibreOffice soit 100% compatible. En tout cas votre fichier ods est arrivé sans macro.
Dans la PJ on insère la date d'audit et on rapatrie toutes les non conformités de toutes les feuilles s'appelant Pxx.
Je ne supprime aucune ligne dans les feuilles.
Voilà, vous avez un squelette nécessaire et suffisant pout fignoler à votre goût.
Pour le post #19, rien compris ... donc non traité.
Il y a suffisament de commentaires pour que vous puissiez facilement modifier le code.
VB:
Sub Audit()
Dim Sh As Worksheet, LigneInsertion As Integer, DerLig As Integer, N As Integer
' Figer écran
Application.ScreenUpdating = False
' N est le nombre de non conformités trouvées
N = 0
' Recherche où se trouve "ÉTABLISSEMENT DE CETTE DÉCLARATION D’ACCESSIBILITÉ" dans la page Declaration.
LigneInsertion = 1 + Application.Match("ÉTABLISSEMENT DE CETTE DÉCLARATION D’ACCESSIBILITÉ*", Sheets("Declaration").Range("A:A"), 0)
' Insertion de la date d'audit
Sheets("Declaration").Range("A" & LigneInsertion) = "Cette déclaration a été établie le " & Format(Date, "dddd dd mmmm yyyy")
' Recherche où se trouve "Non-conformité" dans la page Declaration. C'est la ligne où inserer.
LigneInsertion = 1 + Application.Match("Non-conformité", Sheets("Declaration").Range("A:A"), 0)
' On parcourt toutes les feuilles
For Each Sh In ActiveWorkbook.Sheets
    If Len(Sh.Name) = 3 And Left(Sh.Name, 1) = "P" Then         ' Ne concerne que les feuilles commençant par P et ayant 3 caractères ( type P01 )
        DerLig = Sheets(Sh.Name).Range("D65000").End(xlUp).Row  ' Nombre de lignes de la feuille Pxx
        For Ligne = 4 To DerLig                                 ' Pour toutes les lignes de la feuille Pxx
            If Sheets(Sh.Name).Cells(Ligne, "D") = "NC" Then    ' Si NC alors
                With Sheets("Declaration")                      ' Inserer lignes et ajouter données
                    .Rows(LigneInsertion).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove ' Insertion ligne
                    .Cells(LigneInsertion, 1) = Sheets(Sh.Name).Cells(Ligne, 2)  ' N°
                    .Cells(LigneInsertion, 2) = Sheets(Sh.Name).Cells(Ligne, 3)  ' Critère
                    LigneInsertion = LigneInsertion + 1         ' Incrément index pour la prochaine insertion
                    N = N + 1                                   ' Une non conformité de plus
                End With
            End If
        Next Ligne
   End If
Next Sh
' Sortie avec message
Application.ScreenUpdating = True
MsgBox " Nombre de non conformité trouvées : " & N
End Sub
 

Fichiers joints

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas