Creer une feuille en fonction d'une listbox

Le 28/04/2014 à 08:34

Bonjour a tous,

Donc voilà, j'aurais voulu savoir comment faire pour que lorsque je coche un ou plusieur nom dans une listbox, une feuille protant ce nom se créée, je m'explique :

Au démarage de mon classeur, une feuille nommée "MATRICE" est dupliquée puis cachée. La feuille duppliquée porte le nom "VIERGE", grace à cette macro :

Private Sub Workbook_Open()

    Dim rep As Integer
    rep = MsgBox("Voulez-vous duppliquer les rapports en choisissant les intervenants ?", vbQuestion + vbYesNo)

    If rep = vbYes Then
            Wb_open
            Copi_rap.Show
        Else

            Wb_open
    End If
End Sub

Puis le module Wb_open :

Sub Wb_open()
'copie de la feuille Matrice
        Sheets("MATRICE").Activate
        Sheets("MATRICE").Copy After:=Sheets("MATRICE")
    'On renome la nouvelle feuille
        ActiveSheet.name = "VIERGE"
    ' A l'ouverture du classeur on masque certaine feuilles
        Sheets("MATRICE").Visible = False
    ' On ouvre la boite à outils au démarrage du classeur
        Boite_à_outils.Show
    'Création des mémoire de dossier
        'Ajout_feuille
        'Sheets("chemin").Visible = False

If ThisWorkbook.Sheets("MATRICE").Range("A110").Value = "" Then 'tu peux changer feuille et B1
création_dossier 'création dossier
End If
        If ThisWorkbook.Sheets("MATRICE").Range("A111").Value = "" Then
 To_PDF.Cmd_PDF.Enabled = False
End If

End Sub
Private Sub création_dossier()
Dim rep As String
Dim Mot As String
Dim Position As Integer
rep = Environ("USERPROFILE") & "\"
Mot = "Users"
Position = InStr(rep, Mot)
If Position = 0 Then
CreationRepertoire rep & "Mes documents\", "POINTAGES"
ThisWorkbook.Sheets("MATRICE").Range("A110").Value = rep & "Mes documents\POINTAGES\" 'tu peux changer la feuille et la cellule
Else
CreationRepertoire rep & "Documents\", "POINTAGES"
ThisWorkbook.Sheets("MATRICE").Range("A110").Value = rep & "Documents\POINTAGES\" 'tu peux changer la feuille et la cellule
End If
End Sub
Sub CreationRepertoire(DossierParent As String, NomRep As String)
    Dim chemin As String
 'Vérifie si le répertoire existe.
    If Dir(DossierParent, vbDirectory + vbHidden) <> "" Then
        'Vérifie que le dossier à créer n'existe pas déjà dans le répertoire
        If Dir(DossierParent & "\" & NomRep, vbDirectory + vbHidden) = "" Then _
            MkDir DossierParent & "\" & NomRep
    End If
End Sub

Le code contient d'autre instruction... mais elle ne sont pas nécéssaire pour le moment.

Ma question est que je voudrais que le fait de coché un nom ou plusieurs, ce même principe soit utilisé, mais si je la déssélectionne, la feuille se supprime...

Je ne suis peut être pas très clair... mais pour faire simple :

Je coche mes noms.... >>> les feuilles se crééent en portant les noms tout ça a partir de la "MATRICE" comme si le classeur démarrait...

Merci d'avoir pris le temps de me lire... c'étais pas facile

Bonne journée à tous...

Christian

Le 29/04/2014 à 18:30

Salut,

On peut voir ton fichier ?

Cordialement.

Le 29/04/2014 à 20:16

Bonsoir yvouille...

Il est trop gros... Mais je vais faire un fichier similaire... Et je le post...

Merci

Le 03/05/2014 à 10:02

Salut,

cco86260 a écrit :

N'hésitez pas à me reprendre quand je m'éloigne...

Tu t’éloigne

Amicalement

Le 05/05/2014 à 11:51

Bonjour Yvouille,

Ah bon ?

Bon j'ai trouvé la solution si cela interesse quelqu'un que voici :

Private Sub Cmd_genrap_Click()
Compteur_List5 = ListBox5.ListCount

For i_5 = 0 To Compteur_List5 - 1
  valSelected_5 = ListBox5.List(i_5)
  With ActiveSheet 'Agit sur la feuille active
    On Error Resume Next
    .name = valSelected_5
    'Range("O8") = valSelected_5
    'Range("AZ8") = LblSem.Caption
    'Range("BQ8") = LblDu.Caption
    'Range("CO8") = LblAu.Caption
    'Range("Z11") = TBox_sec.Value
    'Range("AY33") = TextBox66.Value
    'Range("D11") = ComboBox2.Value
    'Range("AL11") = Application.WorksheetFunction.Substitute(TextBox67, vbCrLf, Chr(10))
    'Range("AU11") = Application.WorksheetFunction.Substitute(TextBox68, vbCrLf, Chr(10))
    'Range("BD11") = Application.WorksheetFunction.Substitute(TextBox69, vbCrLf, Chr(10))
    'Range("BM11") = Application.WorksheetFunction.Substitute(TextBox70, vbCrLf, Chr(10))
    'Range("BV11") = Application.WorksheetFunction.Substitute(TextBox72, vbCrLf, Chr(10))
    'Range("CE11") = Application.WorksheetFunction.Substitute(TextBox71, vbCrLf, Chr(10))
    'Range("CN11") = Application.WorksheetFunction.Substitute(TextBox73, vbCrLf, Chr(10))
    'Range("AL19") = Application.WorksheetFunction.Substitute(TextBox74, vbCrLf, Chr(10))
    'Range("AU19") = Application.WorksheetFunction.Substitute(TextBox75, vbCrLf, Chr(10))
    'Range("BD19") = Application.WorksheetFunction.Substitute(TextBox76, vbCrLf, Chr(10))
    'Range("BM19") = Application.WorksheetFunction.Substitute(TextBox77, vbCrLf, Chr(10))
    'Range("BV19") = Application.WorksheetFunction.Substitute(TextBox78, vbCrLf, Chr(10))
    'Range("CE19") = Application.WorksheetFunction.Substitute(TextBox79, vbCrLf, Chr(10))
    'Range("CN19") = Application.WorksheetFunction.Substitute(TextBox80, vbCrLf, Chr(10))
    'Range("AL20") = Application.WorksheetFunction.Substitute(TextBox81, vbCrLf, Chr(10))
    'Range("AU20") = Application.WorksheetFunction.Substitute(TextBox82, vbCrLf, Chr(10))
    'Range("BD20") = Application.WorksheetFunction.Substitute(TextBox83, vbCrLf, Chr(10))
    'Range("BM20") = Application.WorksheetFunction.Substitute(TextBox84, vbCrLf, Chr(10))
    'Range("BV20") = Application.WorksheetFunction.Substitute(TextBox85, vbCrLf, Chr(10))
    'Range("CE20") = Application.WorksheetFunction.Substitute(TextBox86, vbCrLf, Chr(10))
    'Range("CN20") = Application.WorksheetFunction.Substitute(TextBox87, vbCrLf, Chr(10))
    'Range("AL21") = Application.WorksheetFunction.Substitute(TextBox88, vbCrLf, Chr(10))
    'Range("AU21") = Application.WorksheetFunction.Substitute(TextBox89, vbCrLf, Chr(10))
    'Range("BD21") = Application.WorksheetFunction.Substitute(TextBox90, vbCrLf, Chr(10))
    'Range("BM21") = Application.WorksheetFunction.Substitute(TextBox91, vbCrLf, Chr(10))
    'Range("BV21") = Application.WorksheetFunction.Substitute(TextBox92, vbCrLf, Chr(10))
    'Range("CE21") = Application.WorksheetFunction.Substitute(TextBox93, vbCrLf, Chr(10))
    'Range("CN21") = Application.WorksheetFunction.Substitute(TextBox94, vbCrLf, Chr(10))
    'Range("AL22") = Application.WorksheetFunction.Substitute(TextBox95, vbCrLf, Chr(10))
    'Range("AU22") = Application.WorksheetFunction.Substitute(TextBox96, vbCrLf, Chr(10))
    'Range("BD22") = Application.WorksheetFunction.Substitute(TextBox97, vbCrLf, Chr(10))
    'Range("BM22") = Application.WorksheetFunction.Substitute(TextBox98, vbCrLf, Chr(10))
    'Range("BV22") = Application.WorksheetFunction.Substitute(TextBox99, vbCrLf, Chr(10))
    'Range("CE22") = Application.WorksheetFunction.Substitute(TextBox100, vbCrLf, Chr(10))
    'Range("CN22") = Application.WorksheetFunction.Substitute(TextBox101, vbCrLf, Chr(10))
    'Range("AL23") = Application.WorksheetFunction.Substitute(TextBox102, vbCrLf, Chr(10))
    'Range("AU23") = Application.WorksheetFunction.Substitute(TextBox103, vbCrLf, Chr(10))
    'Range("BD23") = Application.WorksheetFunction.Substitute(TextBox104, vbCrLf, Chr(10))
    'Range("BM23") = Application.WorksheetFunction.Substitute(TextBox105, vbCrLf, Chr(10))
    'Range("BV23") = Application.WorksheetFunction.Substitute(TextBox106, vbCrLf, Chr(10))
    'Range("CE23") = Application.WorksheetFunction.Substitute(TextBox107, vbCrLf, Chr(10))
    'Range("CN23") = Application.WorksheetFunction.Substitute(TextBox108, vbCrLf, Chr(10))
    'Range("AL24") = Application.WorksheetFunction.Substitute(TextBox109, vbCrLf, Chr(10))
    'Range("AU24") = Application.WorksheetFunction.Substitute(TextBox110, vbCrLf, Chr(10))
    'Range("BD24") = Application.WorksheetFunction.Substitute(TextBox111, vbCrLf, Chr(10))
    'Range("BM24") = Application.WorksheetFunction.Substitute(TextBox112, vbCrLf, Chr(10))
    'Range("BV24") = Application.WorksheetFunction.Substitute(TextBox113, vbCrLf, Chr(10))
    'Range("CE24") = Application.WorksheetFunction.Substitute(TextBox114, vbCrLf, Chr(10))
    'Range("CN24") = Application.WorksheetFunction.Substitute(TextBox115, vbCrLf, Chr(10))
    'Range("AL25") = Application.WorksheetFunction.Substitute(TextBox116, vbCrLf, Chr(10))
    'Range("AU25") = Application.WorksheetFunction.Substitute(TextBox117, vbCrLf, Chr(10))
    'Range("BD25") = Application.WorksheetFunction.Substitute(TextBox118, vbCrLf, Chr(10))
    'Range("BM25") = Application.WorksheetFunction.Substitute(TextBox119, vbCrLf, Chr(10))
    'Range("BV25") = Application.WorksheetFunction.Substitute(TextBox120, vbCrLf, Chr(10))
    'Range("CE25") = Application.WorksheetFunction.Substitute(TextBox121, vbCrLf, Chr(10))
    'Range("CN25") = Application.WorksheetFunction.Substitute(TextBox122, vbCrLf, Chr(10))
    'Range("AL26") = ComboBox5.Value
    'Range("AU26") = ComboBox6.Value
    'Range("BD26") = ComboBox7.Value
    'Range("BM26") = ComboBox8.Value
    'Range("BV26") = ComboBox9.Value
    'Range("CE26") = ComboBox10.Value
    'Range("CN26") = ComboBox11.Value
CopieFeuille1
Cache_Matrice1
    nbfeuille = ThisWorkbook.Sheets.count
    End With
Next i_5
Unload Me
'Boite_à_outils.Show
End Sub

Sub CopieFeuille1()
Sheets("MATRICE").Visible = True
On Error Resume Next
TOTO = Sheets("VIERGE").name
If Error Then
    Sheets("MATRICE").Copy After:=Sheets("MATRICE")
    ActiveSheet.name = "VIERGE"
End If
On Error GoTo 0
End Sub
Sub Cache_Matrice1()
Sheets("MATRICE").Visible = False
End Sub

J'ai commenté ce qui était en trop...

En espérant que cela aide quesqu'un...

Cordialement,

Christian

Rechercher des sujets similaires à "creer feuille fonction listbox"