Copie plage sous condition

Le 21/05/2020 à 10:39

Bonjour à tous,

Je cherche à copier les éléments d'une base de données remplie via 4 requêtes SQL sur 4 Feuilles différentes (IMP3; IMP2; Absences; GardesVI). Il agit de données de planifications afin d'extraire automatiquement les présences d'agent sur une semaine.

La partie requête est fonctionnelle mais je bute sur la mise en forme des données.

Je dois copier sous plusieurs conditions une plage de colonnes (C:L) sur un nombre de lignes non fixe. Je dois les feuilles de données permettent de copier sur une plage dans chaque feuille des jours de la semaine. selon l'exemple suivant:

  • Copie de Sheets("IMP3").range(C:L & i) si E = Sheets("lundi").range ("A1") et si N est non vide
  • Coller en Sheets("lundi").range ("A4") tout en masquant les cellules lignes vides entre 4 et 10

Voici ce que j'ai débuté à savoir que cela doit fonctionner pour chaque ensemble de données et chaque jour de la semaine:

Sub copietpo() j = 1 For i = 2 To 500 'boucle sur les lignes à vérifier If Sheets("IMP3").Range("E" & i).Value = Sheets("Lundi").Range("A1") Then 'on vérifie la colonne E pour chaque ligne --> si condition vérifiée, on rentre dans la condition Sheets("IMP3").Range("C:L" & i).Copy Destination:=Sheets("Lundi").Range("A5" & j) 'on copie la plage de Feuil1 vers la cellule Aj de Feuil2 j = j + 1 'on passe à la prochaine ligne en Feuil2 End If Next i End Sub

Le but final une fois la copie effectuée: récupérer les plages des Feuilles "SituHebdo" + "tous les jours" et les exporter dans un fichier PDF qui sera transmis par mail.

Je ne serais donc pas contre un grand coup de main

Voici le fichier excel ainsi que ce que cela doit donner au final (traité au moyen de copier collé manuel et de liaison sous Word)

Le 21/05/2020 à 11:10

Bonjour,

La façon la plus simple de copier sous condition est d'utiliser les filtres avancés. Et on eut aussi facilement enregistrer en macro, et en faire plusieurs sur la même page.

Quant à la faire sur le fichier ... il faut d'abord le comprendre ! J'aurais préféré travailler sur un fichier juste cadré sur le problème. Je vais regarder sans y passer trop de temps.

Le 21/05/2020 à 11:38

2 petits écarts (il faut que les en-têtes de colonne soient identiques en filtre avancé) :

  • POSITION, avec un espace inutile après le mot dans un onglet
  • CENTRE DE SECOURS inconnu ... est-ce le CENTRE DE RATTACHEMENT ?

Exemple de macro :

Sub filtre_lundi_CU()
    Sheets("IMP3").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("N3:N4"), CopyToRange:=Range("A3:L3"), Unique:=False
End Sub

avec en N4 dans l'onglet Lu

=ET(SituHebdo!N8=CNUM('IMP3'!E2);'IMP3'!N1<>"")

et en N3 ce que l'on veut

Le 21/05/2020 à 12:08

Le fichier, avec une macro unique valable tous les jours de la semaine

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    If Sh.Name = "Lu" Or Sh.Name = "Ma" Or Sh.Name = "Me" Or Sh.Name = "Je" Or Sh.Name = "Ve" Or Sh.Name = "Sa" Or Sh.Name = "Di" Then
    Sheets("IMP3").Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sh.Range("N3:N4"), CopyToRange:=Sh.Range("A3:L3"), Unique:=False
    End If
End Sub

On peut ensuite compléter en faisant en plus en sorte qu'il n'y ait pas plus de 2 lignes blanches entre les tableaux.

Le 22/05/2020 à 03:48

Nota : les autres tableaux ont dû s'effacer, mais pas de soucis, on peut poursuivre les extractions e reconstituant facilement les en-têtes. Et cela répondra facilement à ta demande de suppression ds lignes vides.

Dis moi déjà si c'est ok et si pour les autres requêtes quels ont les critères. Si c'est les mêmes ce sera rapide.

Le 27/05/2020 à 08:11

Bonjour Steelson,

Tout d'abord un grand merci à toi pour tes réponses ultra rapides et ton intérêt pour le sujet. Et excuse moi pour ma lenteur de réponse ayant eu un WE et début de semaine très chargés sur le plan pro.

J'ai testé ou en tout cas ai essayé de tester ta solution. J'ai commencé par rendre les entêtes de colonne identiques. Si j'ai bien compris j'intègre le code dans "ThisWorkboook" et c'est censé effectuer la copie. J'utilise pour le moment le bouton rafraîchir dans la feuill "SituMens" pour lancer mon module. A ce titre je n'ai eu aucun effet de copie.

Je t'avoue ne pas forcément avoir compris la méthode. Mais je pense que j'ai omis de te donner une information importante. C'est que le critère principal est la date présente sur chaque feuille de journée en A1 ainsi je dois faire la copie de plusieurs lignes de données pour chaque jour:

  • Copie des lignes de la feuille IMP3 (A:L) dans feuill du jour entre les lignes 4 et 10 si la date est = à A1 sur la feuille du jour + si la cell N de la ligne est non vide
  • Copie des lignes de la feuille IMP2 (A:L) dans feuill du jour entre les lignes 14 et 30 si la date est = à A1 sur la feuille du jour + si la cell N de la ligne est non vide
  • Copie des lignes de la feuille Absence (B:D) dans feuill du jour à partir de la ligne 34 si la date est = à A1 sur la feuille du jour
  • possibilité de reproduire la même chose pour la feuille GardeVI en séparant le tableau
Tout cela en masquant les lignes vides à l'issue. Ou en tout cas c'est la vision que je m'en était fait.

Pour info, j'extrait la base de donnée en cliquant sur rafraîchir en "SituMens" à savoir que cela récupère les infos et rempli les feuilles en fonction du mois identifié en "SituMens" les plages remplies sont:

IMP3: C:L

IMP2: C:L

Absence: A:E

Garde VI: A:H

Grâce à ça je récupère les effectifs dans SituHebdo par formule en modifiant le numéro de la semaine en Y5 et c'est cela qui rempli la cellule A1 dans chaque feuille de jour.

J'espère que cela te donne une vision plus complète du fichier.

Est-ce que ça te parait clair?

Le 27/05/2020 à 12:01
tak77 a écrit :

Mais je pense que j'ai omis de te donner une information importante. C'est que le critère principal est la date présente sur chaque feuille de journée en A1 ainsi je dois faire la copie de plusieurs lignes de données pour chaque jour:

C'est en effet ce que j'avais compris, mais cette valeur est inexploitable car tu as mis du texte.

Je prends donc comme valeur SituHebdo!N8

Je vais regarder pour prendre en compte aussi les autres onglets e ne mettant pas plus de 2 lignes vierges entre chaque résultat pour chaque jour.

Le 27/05/2020 à 13:41
Private Sub Workbook_SheetActivate(ByVal f As Object)

    If Not (f.Name = "Lu" Or f.Name = "Ma" Or f.Name = "Me" Or f.Name = "Je" Or f.Name = "Ve" Or f.Name = "Sa" Or f.Name = "Di") Then Exit Sub
    Dim derL As Long

    ' effacement des données
        derL = f.Range("A" & Rows.Count).End(xlUp).Row
        If derL > 2 Then f.Rows("3:" & derL).Delete Shift:=xlUp

    o = "IMP3" ' onglet
        ' première ligne
        derL = f.Range("A" & Rows.Count).End(xlUp).Row + 3
        ' en-têtes
        Sheets(o).Range("A1:L1").Copy Destination:=f.Range("A" & derL)
        ' critères
        f.Range("N" & derL) = "test"
        f.Range("N" & (derL + 1)).FormulaLocal = "=ET($N$1=CNUM('" & o & "'!E2);'" & o & "'!N2<>"""")"
        ' filtre
        Sheets(o).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.Range("N" & derL).CurrentRegion, CopyToRange:=f.Range("A" & derL).CurrentRegion, Unique:=False

    o = "IMP2" ' onglet
        ' première ligne
        derL = f.Range("A" & Rows.Count).End(xlUp).Row + 3
        ' en-têtes
        Sheets(o).Range("A1:L1").Copy Destination:=f.Range("A" & derL)
        ' critères
        f.Range("N" & derL) = "test"
        f.Range("N" & (derL + 1)).FormulaLocal = "=ET($N$1=CNUM('" & o & "'!E2);'" & o & "'!N2<>"""")"
        ' filtre
        Sheets(o).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.Range("N" & derL).CurrentRegion, CopyToRange:=f.Range("A" & derL).CurrentRegion, Unique:=False

    o = "Absence"
        ' première ligne
        derL = f.Range("A" & Rows.Count).End(xlUp).Row + 3
        ' en-têtes
        Sheets(o).Range("B1:D1").Copy Destination:=f.Range("A" & derL)
        ' critères
        f.Range("N" & derL) = "test"
        f.Range("N" & (derL + 1)).FormulaLocal = "=$N$1=CNUM('" & o & "'!G2)"
        ' filtre
        Sheets(o).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.Range("N" & derL).CurrentRegion, CopyToRange:=f.Range("A" & derL).CurrentRegion, Unique:=False

    o = "GardeVI"
        ' première ligne
        derL = f.Range("A" & Rows.Count).End(xlUp).Row + 3
        ' en-têtes
        Sheets(o).Range("B1:D1").Copy Destination:=f.Range("A" & derL)
        ' critères
        f.Range("N" & derL) = "test"
        f.Range("N" & (derL + 1)).FormulaLocal = "=$N$1=CNUM('" & o & "'!J2)"
        ' filtre
        Sheets(o).Range("A1").CurrentRegion.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.Range("N" & derL).CurrentRegion, CopyToRange:=f.Range("A" & derL).CurrentRegion, Unique:=False

End Sub
Le 27/05/2020 à 16:46

En complément ... ne pas toucher à la colonne N, tu peux éventuellement la masquer, mais pas la supprimer !

Le 28/05/2020 à 12:44

Je suis bleuffé merci beaucoup. Ce qui m'énerve c'est clairement de ne pas être capable de faire ça. Je comprend ton code dans les grandes lignes mais ça reste une autre langue pour moi.

Par contre lorsque je rafraîchi mes données (extraction sql) le fait de réactiver une feuille ne met plus à jour les tableaux, sais tu pourquoi?

Etant donné que le but final est d'avoir un fichier qui à l'ouverture extrait le SQL; Copie colle; et regroupe tout dans un fichier pdf pour envoi le fait de passer par sheetsActivate ne risque pas de poser problème? Est ce que je peux juste réaffecter le code?

Le 28/05/2020 à 12:48

Est-ce que dans le fichier après SQL les dates en N1 sont toujours présentes ?

Le 28/05/2020 à 14:28

oui elles le sont, d'ailleurs je pense que rien n'est modifié dans la structure car si je ferme et ouvre le fichier après rafraîchissement les feuilles se mettent à jour de nouveau à l'activation

Rechercher des sujets similaires à "copie plage condition"