Microsoft 365 Nommer des feuilles en fonction des données d'une colonne

AD95

XLDnaute Junior
Bonjour à tous,

Merci d'avance de votre aide :)

Mon besoin est le suivant :

Créer des feuilles pour chaque référence unique qui se trouve dans la Colonne G

Exemple dans le fichier si je fait un filtre dans la colonne G

j'ai 3 référence : AAAA151 & BBBB131 & M432

J'ai besoin d'un code VBA qui créer des feuilles pour chaque réfrence de la colonne G (exemple dans mon excel)

puis copie toutes les lignes de la colonne D à la dernière colonne (jusqu'à la dernière ligne) et la colle dans ca feuille à partir de la colonne D

Et pour clôturer faire un check par feuille sur la colonne F qu'il n'y ai pas de référence en double si y en en double remonter une alerte (case clignotante ou msg popup)
 

Pièces jointes

  • Filtrage_donnée_par_référence.xlsx
    18.7 KB · Affichages: 4
Solution
Je comprends que dans les feuilles vous voulez éviter les doublons en colonne "Nom".

Il s'agit donc de la colonne F qui correspond à la colonne U de la feuille "Sources".

Donc placez dans la feuille "Sources" cette macro qui traite les 4 colonnes R:U :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, d As Object, x$
Set r = Range("A1", UsedRange).Columns(18).Resize(, 4)
Set Target = Intersect(Target.EntireRow, r)
If Target Is Nothing Then Exit Sub
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each r In r.Rows
    If r.Row > 1 And r.Cells(1) <> "" And r.Cells(4) <> "" Then
        x = r.Cells(1) & Chr(1) & r.Cells(4)...

job75

XLDnaute Barbatruc
Bonjour AD95,

Ouvrez le fichier .xlsm joint et exécutez cette macro :
VB:
Sub MAJ()
Dim F As Worksheet, w As Worksheet, d As Object, P As Range, c As Range, x$
Set F = Sheets("Sources")
'---supprime les feuilles---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each w In Worksheets
    If w.Name <> F.Name Then w.Delete
Next w
'---crée les feuilles---
Set d = CreateObject("Scripting.Dictionary")
Set P = F.[A1].CurrentRegion
For Each c In P.Offset(1).Columns(7).Cells
    x = UCase(c)
    If x <> "" And Not d.exists(x) Then
        d(x) = ""
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = x
        P.AutoFilter 7, x 'filtre automatique
        Intersect(P, F.Columns("D:R")).SpecialCells(xlCellTypeVisible).Copy [D1] 'copier-coller
        P.AutoFilter 'ôte le filtre
        Columns.AutoFit 'ajustement largeurs
    End If
Next c
F.Activate
End Sub
A+
 

Pièces jointes

  • Filtrage_donnée_par_référence.xlsm
    29 KB · Affichages: 2

job75

XLDnaute Barbatruc
Et pour clôturer faire un check par feuille sur la colonne F qu'il n'y ai pas de référence en double si y en en double remonter une alerte (case clignotante ou msg popup)
Pour éviter les doublons en colonne F des feuilles placez cette macro dans la feuille "Sources" :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, d As Object, x$
Set r = Range("A1", UsedRange).Columns(6).Resize(, 2)
Set Target = Intersect(Target.EntireRow, r)
If Target Is Nothing Then Exit Sub
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each r In r.Rows
    If r.Row > 1 And r.Cells(1) <> "" And r.Cells(2) <> "" Then
        x = r.Cells(1) & Chr(1) & r.Cells(2) 'concaténation avec séparateur
        d(x) = d(x) + 1 'comptage
    End If
Next r
'---repérage des doublons---
For Each Target In Target.Rows
    If d(Target.Cells(1) & Chr(1) & Target.Cells(2)) > 1 Then
        Application.EnableEvents = False 'désactive les évènements
        Application.Goto Target.Cells(1)
        MsgBox "Doublon en " & Target.Cells(1).Address(0, 0) & " !", 48
        Target.Cells(1) = ""
        Application.EnableEvents = True 'réactive les évènements
        Exit For
    End If
Next Target
End Sub
Elle se déclenche automatiquement quand on modifie ou valide une cellule en colonnes F ou G.
 

Pièces jointes

  • Filtrage_donnée_par_référence.xlsm
    26.3 KB · Affichages: 3

AD95

XLDnaute Junior
Job75

Magnifique c'est clairement le besoin merciiii beaucoup!!!!!!! 💪

J'ai fait des petites modif en rouge sur les colonnes et du coup c'est plus la colonne G (pour la creation des feuilles mais la R) j'ai donc remplacer les 7 (pour la 7eme lettre donc G) par 18 j'ai bien les feuilles qui sont nommées mais pas les données qui vont avec trop nul 😅




Sub MAJ2()
Dim F As Worksheet, w As Worksheet, d As Object, P As Range, c As Range, x$
Set F = Sheets("Sources")
'---supprime les feuilles---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each w In Worksheets
If w.Name <> F.Name Then w.Delete
Next w
'---crée les feuilles---
Set d = CreateObject("Scripting.Dictionary")
Set P = F.[A1].CurrentRegion
For Each c In P.Offset(1).Columns(18).Cells
x = UCase(c)
If x <> "" And Not d.exists(x) Then
d(x) = ""
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = x
P.AutoFilter 18, x 'filtre automatique
Intersect(P, F.Columns("R:AC")).SpecialCells(xlCellTypeVisible).Copy [C1] 'copier-coller
P.AutoFilter 'ôte le filtre
Columns.AutoFit 'ajustement largeurs
End If
Next c
F.Activate
End Sub







Est-il possible d'intégrer ce besoin dans le vba j'ai essayé mais c'est une catastrophe trop novice encore ?

1. Dans les feuilles que le vba va créer et ckecker s'il ya une référence en doublon dans la colonne U et Remonter une alerte (MsgBox ?) avec les lignes concernées

2. Rajouter cette formule dans la colonne AA =SI(U4="Yes";"OK";"KO") si OK (en police verte) si KO (en police rouge) sinon mettre Error

3. Rajouter un contrôle d'erreur si jamais il y a un problème sur la création des feuilles
 

Pièces jointes

  • Filtrage_donnée_par_référenceV3.xlsm
    85.1 KB · Affichages: 3

job75

XLDnaute Barbatruc
La macro MAJ modifiée ne doit pas être appelée MAJ2 car ce nom est une référence de cellule.

A part cela elle fonctionne très bien.

En l'état il ne peut pas y avoir de doublon dans les feuilles créées puisqu'il n'y a qu'une ligne.
 

job75

XLDnaute Barbatruc
Je comprends que dans les feuilles vous voulez éviter les doublons en colonne "Nom".

Il s'agit donc de la colonne F qui correspond à la colonne U de la feuille "Sources".

Donc placez dans la feuille "Sources" cette macro qui traite les 4 colonnes R:U :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, d As Object, x$
Set r = Range("A1", UsedRange).Columns(18).Resize(, 4)
Set Target = Intersect(Target.EntireRow, r)
If Target Is Nothing Then Exit Sub
'---liste sans doublon---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each r In r.Rows
    If r.Row > 1 And r.Cells(1) <> "" And r.Cells(4) <> "" Then
        x = r.Cells(1) & Chr(1) & r.Cells(4) 'concaténation avec séparateur
        d(x) = d(x) + 1 'comptage
    End If
Next r
'---repérage des doublons---
For Each Target In Target.Rows
    If d(Target.Cells(1) & Chr(1) & Target.Cells(4)) > 1 Then
        Application.EnableEvents = False 'désactive les évènements
        Application.Goto Target.Cells(4)
        MsgBox "Doublon en " & Target.Cells(4).Address(0, 0) & " !", 48
        Target.Cells(4) = ""
        Application.EnableEvents = True 'réactive les évènements
        Exit For
    End If
Next Target
End Sub
 

AD95

XLDnaute Junior
Bonjour,

Le code fonctionne nickel merciii beaucoup. Par contre, pour les doublons je me suis mal exprimé sur mon nouveau besoin.

Tu trouveras en PJ un nouveau fichier.
J'ai créer une nouvelle Feuille "old_id" c'est une liste de tous les id existant.

Dans la feuille "AT1"

1 / dans la colonne A j'ai mis la formule =NB.SI.ENS($C$2:$C$758;B2)
(pour compter le nombre de ID en doublons)
si supérieur à 1 mettre la case en rouge

2 / dans la colonne B j'ai mis la formule =RECHERCHEV(C2;id_old!$A$2:$A$534;1;FAUX)
(pour rechercher s'il y a un nouvelle ID non répertorié dans la Feuille "old_id"

S'il ya un nouvel ID mettre la case B en rouge en rouge et rajouter en plus la création d'une feuille qui répertorie tous les nouveau ID de la colonne C avec un copier/coller la colonne C, F, I et J

3 / dans la colonne AA j'ai mis la formule =SI($U2="Yes";"OK";"KO") (s'il contient Yes mette la police en vert et si Ko la police en rouge


Voila ce que j'ai besoin d'intégrer pour toutes les feuilles c'est pour ça que la colonne A et B et vide.

Merci d'avance de ton aide :D
et si c'est pas trop demandé tu peux stp me détailler un peu les lignes pour bien comprendre ce que tu fais j'aimerai un jour arrivée à ton niveau même si j'en suis à des années lumière 😅 si tu as des astuces/sites pour apprendre je suis preneur. Encore merci pour ton temps.
 

Pièces jointes

  • Filtrage_donnée_par_référenceV6.xlsm
    162.6 KB · Affichages: 2

AD95

XLDnaute Junior
Bonjour,

C'est bon j'ai trouvé ma formule pour les doublons ça marche nikel le seul hic c'est que j'arrive pas à lui dire d'étendre la formule jusqu'à la dernière ligne de la colonne C (aucun résultat) du coup j'ai défini la fin manuellement jusqu'à 10000 lignes :(



Dim dernièreLigne As Long

' Trouver la dernière ligne de la colonne C
dernièreLigne = Cells(Rows.Count, 3).End(xlUp).row

' Appliquer la formule dans la colonne A
Range("A2:A" & dernièreLigne).Formula = "=COUNTIFS(R2C3:R1000C3,RC[1])"

' Appliquer la formule dans la colonne B
Range("B2:B" & dernièreLigne).Formula = "=VLOOKUP(R2C3:R[9998]C[1],'ITB synthesis'!R6C1:R1000C1,1,FALSE)"

' Appliquer la formule dans la colonne AA
Range("AA2:AA" & dernièreLigne).Formula = "=IF(RC[15]=""Yes"",""OK"",""KO"")"
 

Discussions similaires

Statistiques des forums

Discussions
312 864
Messages
2 093 019
Membres
105 609
dernier inscrit
Marcali