Incrémentation automatique de données de plusieurs feuilles sur une autre feuille suivant un certain critère

Ceiste · Février 17, 2018, 4:00

Bonjour,

Je suis débutant sur Excel et suis à la recherche d’une solution.

J’ai un classeur Excel 2016 comportant six feuilles.
Ces feuilles comportent des renseignements sur des personnes avec possession ou non de badges d’ accés.

Je souhaiterais obtenir en automatiquePoint badges accés.xlsx (32,5 Ko)
sur une septième feuille les renseignements des personnes ,mais uniquement celles
qui possèdent un badge d’accés.

Quelle formule(s) utiliser pour obtenir ce résultat ?

Pour plus de précisions je joins le fichier.

J’espère avoir été suffisamment clair.

Merci de bien vouloir m’aider.

Mimimathy · Février 17, 2018, 4:27

Bonjour,

A tester

Module:

Sub Transfert()
Dim Ws As Worksheet, Wd As Worksheet, Dl%, i%, j% 'Déclaration des variables
Application.ScreenUpdating = False 'Désactive le rafraissement Ecran
Range("A2:J65000").ClearContents 'nettoie la feuille Recap
j = 2
Set Wd = Sheets("BADGES D ACCES")
  For Each Ws In Worksheets 'Boucle sur les onglets
    If Ws.Name <> "BADGES D ACCES" Then 'sauf l'onglet de RECAP
    Sheets(Ws.Name).Activate 'Active l'onglet
    Set Ws = Sheets(Ws.Name)
    Dl = Range("A" & Rows.Count).End(xlUp).Row 'n° de la dernière ligne non vide de la colonne A
      For i = 2 To Dl 'boucle sur les lignes
        If Cells(i, 9) <> "" Then 'si la cellue colonne "I" n'est pas vide
          Ws.Range(Cells(i, 1), Cells(i, 10)).Copy Wd.Cells(j, 1) 'copie vers la feuille Recap
          j = j + 1 'ajoute 1 au compteur de ligne feuille Recap
        End If
      Next i
      End If
  Next Ws
  Sheets("BADGES D ACCES").Activate
  Range("A2").Select
  Application.ScreenUpdating = True
End Sub

Point badges accés.xlsm (44,2 Ko)

Ceiste · Février 17, 2018, 5:34

Merci,
La solution me convient et elle répond au problème posé.
Je vais donc poser le problème correctement cette fois- ci(désolé)
Sur les six feuilles il y a plusieurs colonnes qui ne m’ intéresse pas et que je ne veux pas trouver dans le résultat sur la septième feuille.
Je joins en PJ le fichier avec les colonnes supplémentaires.

Merci encore
CordialementPoint badges accés-A .xlsx (33,2 Ko)

Mimimathy · Février 17, 2018, 5:48

Re,

A voir
Point badges accés-A .xlsm (44,4 Ko)

Ceiste · Février 18, 2018, 8:34

Bonjour
Au fur et à mesure que le fichier avance les difficultés se présentent.
Dans le fichier joint il faudrait que l’on trouve les personnels possédant des badges d’accès,
mais sans prendre en compte les feuilles A,B,C et uniquement les colonnes déjà présentes dans la feuille Badge d’accès.

Merci de voir ce que vous pouvez faire pour moi.

Cordialement
Bon dimanchePoint badges accés-B.xlsx (40,3 Ko)

mdo100 · Février 18, 2018, 9:25

Bonjour @Ceiste,
Salut l’ami @Mimimathy,

Je me suis permis de modifier ton code @Mimimathy, mais sans doute pourrais-tu faire mieux.

Code VBA de @Mimimathy modifié:

 Option Explicit

Sub Transfert()

Dim Ws As Worksheet, Wd As Worksheet, Dl%, i%, j% 'Déclaration des variables
Application.ScreenUpdating = False 'Désactive le rafraissement Ecran
Range("A2:J65000").ClearContents 'nettoie la feuille Recap
j = 2
Set Wd = Sheets("BADGES D ACCES")
  For Each Ws In Worksheets 'Boucle sur les onglets
    If Ws.Name <> "BADGES D ACCES" And Ws.Name <> "A" And Ws.Name <> "B" And Ws.Name <> "C" Then 'sauf l'onglet de RECAP, A, B, C
    Sheets(Ws.Name).Activate 'Active l'onglet
    Set Ws = Sheets(Ws.Name)
    Dl = Range("A" & Rows.Count).End(xlUp).Row 'n° de la dernière ligne non vide de la colonne A
      For i = 2 To Dl 'boucle sur les lignes
        If Cells(i, 11) <> "" Then 'si la cellue colonne "I" n'est pas vide
          Ws.Range(Cells(i, 1), Cells(i, 8)).Copy Wd.Cells(j, 1) 'copie vers la feuille Recap
          Ws.Range(Cells(i, 13), Cells(i, 13)).Copy Wd.Cells(j, 9) 'copie vers la feuille Recap
          j = j + 1 'ajoute 1 au compteur de ligne feuille Recap
        End If
      Next i
      End If
  Next Ws
  Sheets("BADGES D ACCES").Activate
  Range("A2").Select
  Application.ScreenUpdating = True
  
End Sub

Fichier ICI==> Point badges accès-B.xlsm (53,8 Ko)

Bon dimanche.
Cordialement.

Ceiste · Février 18, 2018, 10:04

Bonjour et merci

Quand on exécute la Macro elle ne rend pas l’effet escompté elle totalise quand même les feuilles A,B,C.

Bonne journée
Cordialement

Mimimathy · Février 18, 2018, 10:16

Bonjour à tous,

Dans la macro, il faut juste remplacer la ligne
If Ws.Name <> « BADGES D ACCES » And Ws.Name <> « A » And Ws.Name <> « B » And Ws.Name <> « C » Then 'sauf l’onglet de RECAP, A, B, C

par

If Ws.Name Like "ALPHA*" Then

Ainsi, il ne prend en charge que les onglets commencant par « ALPHA »

Pour MDO, le raisonnement était bon, seulement Ceiste ne sait pas encore que quand on nomme les onglets, on ne met pas d’ESPACE AVANT OU APRES un nom

mdo100 · Février 18, 2018, 10:54

Re @Ceiste,

Oupss Je n’ais pas vérifié le résultat avant de publier, c’est réparé avec la proposition de @Mimimathy.

Cdlt.

mdo100 · Février 18, 2018, 11:01

Re @Mimimathy,

Je dois bien avouer, que comme je n’avais pas vérifié le résultat, je n’avais pas vu non plus l’espace en trop dans les feuilles “A, B, C”.

Ce qui fait de moi, un bricoleur de macro du dimanche

Amicalement.

Ceiste · Février 18, 2018, 11:08

Merci à vous deux

Bon dimanche

Mimimathy · Février 18, 2018, 2:56

Re,
Ce qui fait de moi, un bricoleur de macro du dimanche

Non, tu sauras que c’est toujours l’erreur la plus évidente la moins recherchée,
entre les espaces, les cellules aux format Texte, et j’en passe et des meilleures, on recherche toujours la difficultés, alors qu’elle crève des fois les yeux ou la réflexion
Hum. ben alors pourquoi mais çà bien sûr youpi le top