ajout/suppression automatique feuille si cellule remplie/vide

[hadswimmer]

Bonjour le forum,

Je veux créer un formulaire avec une feuille de base (tableau vide).
Lorsque la première case de ce tableau se remplit, je voudrais qu'un onglet soit automatiquement ajouté, en copie d'une feuille existante et renommer l'onglet. Jusque là, ça passe.

J'aimerais donc que la même opération ait lieu quand je supprime la valeur du tableau de base...et là je bloque.
Je pense que dans mon code la faute se trouve dans la sélection de la cellule...mais je n'arrive pas à résoudre cela.

En annexe, un fichier simplifié, avec mon code (et les erreurs qui vont avec )

Merci d'avance,

Cordialement,

 

[hadswimmer]

Re : ajout/suppression automatique feuille si cellule remplie/vide

Je me relis et je remarque que je n'ai pas été clair dans la problématique.

Quand je supprime la case de mon tableau (que je la rend donc vide), je souhaite alors que la feuille qui avait été créée suite à cette entrée soit supprimé.

Encore merci!

 

[job75]

Re : ajout/suppression automatique feuille si cellule remplie/vide

Bonjour hadswimmer,

Coller dans le code de Feuil1 (clic droit sur l'onglet et Visualiser le code) :

Private Sub Worksheet_Change(ByVal Target As Range)
'Feuil2 est le CodeName de la feuille modèle à copier
Dim r As Range, w As Worksheet, i As Variant
Set r = Range("B6", Range("B" & Rows.Count).End(xlUp)(6))
If Intersect(Target, r) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---suppresion de feuilles et repérage en colonne C---
r.Columns(2).ClearContents 'par précaution
For Each w In Worksheets
  If w.CodeName <> Me.CodeName And w.CodeName <> "Feuil2" Then
    i = Application.Match(w.Name, r, 0)
    If IsNumeric(i) Then r(i, 2) = 1 Else w.Delete
  End If
Next
'---Ajout de feuilles---
For i = 1 To r.Count
  If r(i) <> "" And r(i, 2) = "" Then
    Feuil2.Copy After:=Sheets(Sheets.Count)
    On Error Resume Next 'en cas de caractère interdit
    Sheets(Sheets.Count).Name = CStr(r(i))
    If Sheets(Sheets.Count).Name <> CStr(r(i)) Then _
      MsgBox "Feuille déjà créée ou caractère interdit en " & r(i).Address(0, 0), 48 _
        : Sheets(Sheets.Count).Delete
    On Error GoTo 0
  End If
Next
r.Columns(2).ClearContents 'RAZ
Me.Activate
End Sub

Entrez ou effacez des valeurs en B6 et cellules suivantes.

Nota : la colonne C est utilisée pour le repérage, ne rien y inscrire.

A+

 

[job75]

Re : ajout/suppression automatique feuille si cellule remplie/vide

Re,

Avec des tableaux VBA (matrices) c'est plus rapide et la colonne auxiliaire n'est plus nécessaire :

Private Sub Worksheet_Change(ByVal Target As Range)
'Feuil2 est le CodeName de la feuille modèle à copier
Dim r As Range, t, repere(), w As Worksheet, i As Variant
Set r = Range("B6", Range("B" & Rows.Count).End(xlUp)(7))
If Intersect(Target, r) Is Nothing Then Exit Sub
t = r 'matrice, plus rapide
ReDim repere(1 To UBound(t), 1 To 1)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---suppresion de feuilles et repérage---
For Each w In Worksheets
  If w.CodeName <> Me.CodeName And w.CodeName <> "Feuil2" Then
    i = Application.Match(w.Name, r, 0)
    If IsNumeric(i) Then repere(i, 1) = 1 Else w.Delete
  End If
Next
'---Ajout de feuilles---
For i = 1 To UBound(t)
  If t(i, 1) <> "" And repere(i, 1) = "" Then
    Feuil2.Copy After:=Sheets(Sheets.Count)
    On Error Resume Next 'en cas de caractère interdit
    Sheets(Sheets.Count).Name = CStr(t(i, 1))
    If Sheets(Sheets.Count).Name <> CStr(t(i, 1)) Then _
      MsgBox "Feuille déjà créée ou caractère interdit en " & r(i).Address(0, 0), 48 _
        : Sheets(Sheets.Count).Delete
    On Error GoTo 0
  End If
Next
Me.Activate
End Sub

A+

 

[job75]

Re : ajout/suppression automatique feuille si cellule remplie/vide

Re,

Avec les macros précédentes, la colonne B étant vide, si l'on entre une donnée en B8 la feuille se crée.

Si ensuite on efface B8 la feuille n'est pas supprimée.

Pour y remédier faire porter le 1er test sur toute la colonne :

Private Sub Worksheet_Change(ByVal Target As Range)
'Feuil2 est le CodeName de la feuille modèle à copier
Dim r As Range, t, repere(), w As Worksheet, i As Variant
Set r = Range("B6", Range("B" & Rows.Count).End(xlUp)(7))
If Intersect(Target, r.EntireColumn) Is Nothing Then Exit Sub
t = r 'matrice, plus rapide
ReDim repere(1 To UBound(t), 1 To 1)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'---suppresion de feuilles et repérage---
For Each w In Worksheets
  If w.CodeName <> Me.CodeName And w.CodeName <> "Feuil2" Then
    i = Application.Match(w.Name, r, 0)
    If IsNumeric(i) Then repere(i, 1) = 1 Else w.Delete
  End If
Next
'---Ajout de feuilles---
For i = 1 To UBound(t)
  If t(i, 1) <> "" And repere(i, 1) = "" Then
    Feuil2.Copy After:=Sheets(Sheets.Count)
    On Error Resume Next 'en cas de caractère interdit
    Sheets(Sheets.Count).Name = CStr(t(i, 1))
    If Sheets(Sheets.Count).Name <> CStr(t(i, 1)) Then _
      MsgBox "Feuille déjà créée ou caractère interdit en " & r(i).Address(0, 0), 48 _
        : Sheets(Sheets.Count).Delete
    On Error GoTo 0
  End If
Next
Me.Activate
End Sub

Bonne soirée.