XL 2016 vba excel

abdallah12

XLDnaute Nouveau
salut les amis je sollicite votre aide
j'ai crée avec VBA un macro qui ajoute des feuilles puis les renommer selon les noms qui se trouve dans les cellules de la colonne "A" de ma feuille base, meme quand j'ajoute un nom dans la meme colonne il l'attribue a une nouvelle feuille qu'il crée automatiquement. pour éviter le message derreur "ce nom est deja attribué" j'ai mis dans le code " if target.column = "" then exit sub" et quand je clique sur une cellule vide pas de message d'erreure. du coup quand je saisi un nouveau nom il ne suffit plus de valider avec la touche "entrer" pour avoir une nouvelle feuille mais il faut que je clique a nouveau sur la cellule precedente. en plus si je clique sur une des cellules non vide de cette meme colonne ce meme message "ce nom est deja attribué" s'affiche a nouveau.

Merci d'avance
 
Solution
Bonjour abdallah12, bienvenue sur XLD,

Voyez le fichier joint et cette macro dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, tablo, i&, x$, a
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
'---liste sans doublon des noms en colonne A---
tablo = UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
    x = Trim(CStr(tablo(i, 1)))
    If x <> "" Then d(x) = ""
Next i
'---suppression des feuilles non inscrites en colonne A---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
    x =...

job75

XLDnaute Barbatruc
Bonjour abdallah12, bienvenue sur XLD,

Voyez le fichier joint et cette macro dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, tablo, i&, x$, a
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
'---liste sans doublon des noms en colonne A---
tablo = UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
    x = Trim(CStr(tablo(i, 1)))
    If x <> "" Then d(x) = ""
Next i
'---suppression des feuilles non inscrites en colonne A---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
    x = Sheets(i).Name
    If LCase(x) <> "accueil" Then
        If d.exists(x) Then
            d.Remove x 'retire de la liste
        Else
            Sheets(i).Delete 'supprime la feuille
        End If
    End If
Next i
If d.Count = 0 Then Exit Sub
'---création des feuilles---
a = d.keys
For i = 0 To UBound(a)
    If LCase(a(i)) <> "accueil" Then
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = a(i)
    End If
Next i
Sheets("Accueil").Activate
End Sub
Elle se déclenche quand on ajoute ou supprime un texte en colonne A.

A+
 

Pièces jointes

  • Classeur(1).xlsm
    17.6 KB · Affichages: 18

abdallah12

XLDnaute Nouveau
Bonjour abdallah12, bienvenue sur XLD,

Voyez le fichier joint et cette macro dans le code de la feuille (clic droit sur l'onglet et Visualiser le code) :
VB:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, tablo, i&, x$, a
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
'---liste sans doublon des noms en colonne A---
tablo = UsedRange.Columns(1).Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
For i = 2 To UBound(tablo)
    x = Trim(CStr(tablo(i, 1)))
    If x <> "" Then d(x) = ""
Next i
'---suppression des feuilles non inscrites en colonne A---
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = Sheets.Count To 1 Step -1
    x = Sheets(i).Name
    If LCase(x) <> "accueil" Then
        If d.exists(x) Then
            d.Remove x 'retire de la liste
        Else
            Sheets(i).Delete 'supprime la feuille
        End If
    End If
Next i
If d.Count = 0 Then Exit Sub
'---création des feuilles---
a = d.keys
For i = 0 To UBound(a)
    If LCase(a(i)) <> "accueil" Then
        Sheets.Add After:=Sheets(Sheets.Count)
        ActiveSheet.Name = a(i)
    End If
Next i
Sheets("Accueil").Activate
End Sub
Elle se déclenche quand on ajoute ou supprime un texte en colonne A.

A+
Vraiment Merci beaucoup j'avoue que "merci" ne suffit pas pour cette beauté mais malheureusement je n'ai que ça à offrir. Je suis vraiment content
C'est vraiment impeccable
Merci encore
 

Discussions similaires

Réponses
5
Affichages
264

Statistiques des forums

Discussions
294 210
Messages
1 936 894
Membres
188 098
dernier inscrit
flow77