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

[AD95]

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)

 

[job75]

Bonjour AD95,

Ouvrez le fichier .xlsm joint et exécutez cette macro :

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+

 

[job75]

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" :

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.

 

[AD95]

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

 

[job75]

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]

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 :

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

 

[job75]

Une correction à apporter aux posts #3 et #6.

Si plusieurs doublons peuvent être créés simultanément, il faut retirer Exit For en bas des macros.

Bonne nuit.

 

[AD95]

Une correction à apporter aux posts #3 et #6.

Si plusieurs doublons peuvent être créés simultanément, il faut retirer Exit For en bas des macros.

Bonne nuit.

 

[AD95]

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
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.

 

[AD95]

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"")"