Microsoft 365 Ajout d'onglet par VBA et entête de colonnes

Roseline · 28 Mai 2024

Bonjour,
J'ai un gros fichier contenant beaucoup de données. J'aurais besoin d'aide en ce qui touche ma VBA.

Mon premier onglet "Suivi des dossiers" comporte beaucoup de colonnes et j'ai un autre onglet nommé "donnée" qui me sert de base pour mes menus déroulants.

Dans un premier temps je dois ajouter des colonnes au début et elles doivent être nommées Villes - Types d'achat et # factures et une autre Résultats et peu plus loin. Jusque là tout va bien.

Où j'ai de la difficulté

Premièrement:
Insérer le menu déroulant par vba dans la colonne de la Ville et dans la colonne Type d'achat que je viens d'ajouter. Ce menu doit s'ajouter automatiquement à chaque fois que je clique sur le bouton ajouter colonnes car je vais devoir en ajouter d'autres à différentes périodes et avec des menus déroulants différents aussi. De plus si j'ai besoin de changer la colonne en format Date par exemple, je suis incapable de le faire dans ma vba.

Deuxièmement:
J'ai automatisé la création d'onglets pour chacun des employés nommé dans la colonne E mais je suis incapable d'ajouter automatiquement l'entête des colonnes dans chacun des onglets et de faire le transfert des données automatiquement pour chaque employé dans chacun son onglet en fonction de son nom dans la colonne E. la commande que j'ai mis le fait bien mais pour un employé seulement, je suis incapable de le faire pour tous les employés inscrits dans la feuille "suivi de dossiers"

J'ai joint un fichier pour une meilleure compréhension.

Merci de votre précieuse aide et bonne journée

AtTheOne · 1 Juin 2024

Bonjour à toutes & à tous, bonjour @Roseline
Bon, j'ai recréé ton fichier avec 2 Subs et la fonction FeuilleExiste (j'ai aussi j'ai recopié ton userform)

Pour la fonction, je te propose une méthode plus rapide, surtout si tu as beaucoup de feuilles dans ton classeur. (idée de Laurent LONGRE)

La macro de création de colonne inclus les validations de données et, à titre d'exemple, une mise en forme pour des dates.
Les validations de données utilisent des noms définis pointant vers les tableaux structurées de l'onglet données.

La macro de création et transfert de données vers les feuilles Employés utilise des tableaux VBA pour les données (plus rapides que l’accès aux cellules) et des dictionnaires pour identifier les lignes à...

AtTheOne · 6 Juin 2024

Re
Mais il suffit de déplacer cette partie :

AtTheOne à dit:
'Ajouter le bouton Set Shp = .Shapes.AddShape(msoShapeRoundedRectangle, .[J1].Left, .[J1].Top, 180, 30) Shp.OnAction = "InsérerLigne" With Shp.TextFrame2 .VerticalAnchor = msoAnchorMiddle With .TextRange .Font.Size = 16 .Font.Bold = True .Text = "Ajouter ligne" With .ParagraphFormat .Alignment = msoTextEffectAlignmentCentered End With End With End With

Juste à cet endroit :

AtTheOne à dit:
If FeuilleExiste(CStr(clef)) Then '=>ne pas tenter de créer une feuile qui existe déjà Set wSh = ThisWorkbook.Worksheets(CStr(clef)) Else Texte = Texte & Chr(10) & Chr(9) & "Employé " & clef Set wSh = ThisWorkbook.Worksheets.Add(before:=shDonnées) 'Création de la feuille Employé

ICI

ActiveWindow.DisplayGridlines = False With wSh .Name = clef 'Attribution du nom .Cells(lgn1, 1).Resize(1, nbcol).Value = TitresCol 'Coller les titres de colonne End With End If

AtTheOne · 7 Juin 2024

Bonjour à toutes & à tous, bonjour @Roseline
J'ai répondu un peu vite hier (dans un car qui roulait et sur mon téléphone (donc sans tester))
Le point désinsertion du code n'est pas tout à fait le bon c'est ici :
If FeuilleExiste(CStr(clef)) Then '=>ne pas tenter de créer une feuile qui existe déjà
Set wSh = ThisWorkbook.Worksheets(CStr(clef))
Else
Texte = Texte & Chr(10) & Chr(9) & "Employé " & clef
Set wSh = ThisWorkbook.Worksheets.Add(before:=shDonnées) 'Création de la feuille Employé
ActiveWindow.DisplayGridlines = False
With wSh
.Name = clef 'Attribution du nom
.Cells(lgn1, 1).Resize(1, nbcol).Value = TitresCol 'Coller les titres de colonne
Insérer ICI
End With
End If

Donc le code résultant est

VB:

'=====================================================================================
'Transfert des données "Employé" après éventuelle création de la feuille correspondant
'=====================================================================================
Sub TransfertDonnéesEmployés()
     Dim wShSce As Worksheet, wSh As Worksheet
     Dim Dico As Object, DicLgn As Object
     Dim Shp As Shape
     
     Application.ScreenUpdating = False
     
     Set Dico = CreateObject("Scripting.Dictionary")
     Set DicLgn = CreateObject("Scripting.Dictionary")
     
     'Lecture de la feuille source (ici "Suivi des dossiers")
     Set wShSce = ShSuivi
     With wShSce
          If .FilterMode Then .ShowAllData
          ColEmployé = WorksheetFunction.Match("Employé", .Rows(lgn1), 0)
          tbdonnées = .Cells(lgn1, 1).CurrentRegion
     End With
     NbLgnSce = UBound(tbdonnées, 1)
     nbcol = UBound(tbdonnées, 2)
     
     ReDim TitresCol(1 To 1, 1 To nbcol)     'titre des colonnes à copier
     For j = 1 To nbcol
          TitresCol(1, j) = tbdonnées(1, j)
     Next
     
     'Collecte dans un dictionnaire des employés et des lignes qui leur correspondent
     DicLgn("1") = 1
     For i = 2 To UBound(tbdonnées)
          If tbdonnées(i, ColEmployé) <> "" Then Dico(tbdonnées(i, ColEmployé)) = Dico(tbdonnées(i, ColEmployé)) & "¤" & i
          DicLgn(CStr(i)) = i
     Next i

     clefs = Dico.Keys: valeurs = Dico.Items
     n = -1
     Message = "Nouvelle(s) feuille(s) crée(s) :"
     Texte = Message
     For Each clef In clefs
          n = n + 1
          If FeuilleExiste(CStr(clef)) Then  '=>ne pas tenter de créer une feuile qui existe déjà
               Set wSh = ThisWorkbook.Worksheets(CStr(clef))
          Else
               Texte = Texte & Chr(10) & Chr(9) & "Employé " & clef
               Set wSh = ThisWorkbook.Worksheets.Add(before:=shDonnées)    'Création de la feuille Employé
               
               ActiveWindow.DisplayGridlines = False
               With wSh
                    .Name = clef                                           'Attribution du nom
                    .Cells(lgn1, 1).Resize(1, nbcol).Value = TitresCol     'Coller les titres de colonne
                    'Ajouter le bouton
                    Set Shp = .Shapes.AddShape(msoShapeRoundedRectangle, .[J1].Left, .[J1].Top, 180, 30)
                    Shp.OnAction = "InsérerLigne"
                    With Shp.TextFrame2
                         .VerticalAnchor = msoAnchorMiddle
                         With .TextRange
                              .Font.Size = 16
                              .Font.Bold = True
                              .Text = "Ajouter ligne"
                              With .ParagraphFormat
                                   .Alignment = msoTextEffectAlignmentCentered
                              End With
                         End With
                    End With
               End With
          End If
          
         With wSh
               LgnDéb = .Cells(.Rows.Count, ColEmployé).End(xlUp).Row     'Première ligne libre dans la colonne Employé
               LgnàCopier = Split(valeurs(n), "¤")                              'Identifier les lignes à copier (l'élément 0 est vide et ne sera pas lu)
               nblgn = UBound(LgnàCopier)
               ReDim tbres(1 To nblgn, 1 To nbcol)                              'Créer un tableau avec les valeurs à copier
               For i = 1 To nblgn
                    For j = 1 To nbcol
                         tbres(i, j) = tbdonnées(LgnàCopier(i), j)
                    Next j
                    DicLgn.Remove LgnàCopier(i)                                 'Retire cette ligne du dictionnaire des lignes à conserver
               Next i
               .Cells(LgnDéb + 1, 1).Resize(nblgn, nbcol).Value = tbres         'Coller les valeur dans la feuille Employé
               
               'Validation des données
               derlgn = .Cells(.Rows.Count, ColEmployé).End(xlUp).Row
               With .Range(.Cells(lgn1 + 1, 1), .Cells(derlgn, 1)).Validation   'de la 1ère ligne de saisie à la dernière (col A)
                    .Delete
                    .Add Type:=xlValidateList, Formula1:="=chx_Ville"           'utilisation du nom défini chx_ville
               End With
               
               With .Range(.Cells(lgn1 + 1, 2), .Cells(derlgn, 2)).Validation   'de la 1ère ligne de saisie à la dernière (col B)
                    .Delete
                    .Add Type:=xlValidateList, Formula1:="=chx_Type"            'utilisation du nom défini chx_type
               End With
               
               'Mettre un format (jjj*  jj/mm/aaa) par exemple en colonne 4
               With .Range(.Cells(lgn1 + 1, 4), .Cells(derlgn, 4))
                    .NumberFormatLocal = "jjj* jj/mm/aaaa"
                    .HorizontalAlignment = xlRight
                    .IndentLevel = 1
               End With
               'format conditionnel pour bordures
               Application.Goto .Cells(lgn1, 1)
               With .Range(.Cells(lgn1, 1), .Cells(.Rows.Count, ColEmployé)).FormatConditions
                    .Delete
                    With .Add(xlExpression, Formula1:="=" & wSh.Cells(lgn1, ColEmployé).Address(False, True, xlA1) & "<>""""")
                         .Borders.LineStyle = xlContinuous
                         .Borders.Color = 12874308
                    End With
               End With
               wShSce.Rows(lgn1).Copy
               .Rows(lgn1).PasteSpecial Paste:=xlPasteColumnWidths
               If Not .AutoFilterMode Then .Cells(lgn1, 1).AutoFilter
          
          End With
     Next
     
     lgnAconserver = DicLgn.Count    'nbre de lignes à conserver restantes
     
     'Constitution d'une tableau des données à conserver
     ReDim tbres(1 To lgnAconserver, 1 To nbcol)
     clefs = DicLgn.Keys: valeurs = DicLgn.Items
     For i = 1 To lgnAconserver
          l = valeurs(i - 1)
          For j = 1 To nbcol
               tbres(i, j) = tbdonnées(l, j)
          Next
     Next
     
     'Effacer les anciennes données et coller les données à conserver
     With wShSce
          .Cells(lgn1, 1).CurrentRegion.ClearContents
          .Cells(lgn1, 1).Resize(lgnAconserver, nbcol) = tbres
          If Not .AutoFilterMode Then .Cells(lgn1, 1).AutoFilter
          .Activate
     End With
     Application.ScreenUpdating = True
     If Texte <> Message Then MsgBox Title:="Création de feuilles employé", Prompt:=Texte

End Sub

Voir la PJ
A bientôt

Roseline · 18 Juin 2024

AtTheOne à dit:

Bonjour à toutes & à tous, bonjour @Roseline
J'ai répondu un peu vite hier (dans un car qui roulait et sur mon téléphone (donc sans tester))
Le point désinsertion du code n'est pas tout à fait le bon c'est ici :
If FeuilleExiste(CStr(clef)) Then '=>ne pas tenter de créer une feuile qui existe déjà
Set wSh = ThisWorkbook.Worksheets(CStr(clef))
Else
Texte = Texte & Chr(10) & Chr(9) & "Employé " & clef
Set wSh = ThisWorkbook.Worksheets.Add(before:=shDonnées) 'Création de la feuille Employé
ActiveWindow.DisplayGridlines = False
With wSh
.Name = clef 'Attribution du nom
.Cells(lgn1, 1).Resize(1, nbcol).Value = TitresCol 'Coller les titres de colonne
Insérer ICI
End With
End If

Donc le code résultant est

VB:

'=====================================================================================
'Transfert des données "Employé" après éventuelle création de la feuille correspondant
'=====================================================================================
Sub TransfertDonnéesEmployés()
     Dim wShSce As Worksheet, wSh As Worksheet
     Dim Dico As Object, DicLgn As Object
     Dim Shp As Shape
    
     Application.ScreenUpdating = False
    
     Set Dico = CreateObject("Scripting.Dictionary")
     Set DicLgn = CreateObject("Scripting.Dictionary")
    
     'Lecture de la feuille source (ici "Suivi des dossiers")
     Set wShSce = ShSuivi
     With wShSce
          If .FilterMode Then .ShowAllData
          ColEmployé = WorksheetFunction.Match("Employé", .Rows(lgn1), 0)
          tbdonnées = .Cells(lgn1, 1).CurrentRegion
     End With
     NbLgnSce = UBound(tbdonnées, 1)
     nbcol = UBound(tbdonnées, 2)
    
     ReDim TitresCol(1 To 1, 1 To nbcol)     'titre des colonnes à copier
     For j = 1 To nbcol
          TitresCol(1, j) = tbdonnées(1, j)
     Next
    
     'Collecte dans un dictionnaire des employés et des lignes qui leur correspondent
     DicLgn("1") = 1
     For i = 2 To UBound(tbdonnées)
          If tbdonnées(i, ColEmployé) <> "" Then Dico(tbdonnées(i, ColEmployé)) = Dico(tbdonnées(i, ColEmployé)) & "¤" & i
          DicLgn(CStr(i)) = i
     Next i

     clefs = Dico.Keys: valeurs = Dico.Items
     n = -1
     Message = "Nouvelle(s) feuille(s) crée(s) :"
     Texte = Message
     For Each clef In clefs
          n = n + 1
          If FeuilleExiste(CStr(clef)) Then  '=>ne pas tenter de créer une feuile qui existe déjà
               Set wSh = ThisWorkbook.Worksheets(CStr(clef))
          Else
               Texte = Texte & Chr(10) & Chr(9) & "Employé " & clef
               Set wSh = ThisWorkbook.Worksheets.Add(before:=shDonnées)    'Création de la feuille Employé
              
               ActiveWindow.DisplayGridlines = False
               With wSh
                    .Name = clef                                           'Attribution du nom
                    .Cells(lgn1, 1).Resize(1, nbcol).Value = TitresCol     'Coller les titres de colonne
                    'Ajouter le bouton
                    Set Shp = .Shapes.AddShape(msoShapeRoundedRectangle, .[J1].Left, .[J1].Top, 180, 30)
                    Shp.OnAction = "InsérerLigne"
                    With Shp.TextFrame2
                         .VerticalAnchor = msoAnchorMiddle
                         With .TextRange
                              .Font.Size = 16
                              .Font.Bold = True
                              .Text = "Ajouter ligne"
                              With .ParagraphFormat
                                   .Alignment = msoTextEffectAlignmentCentered
                              End With
                         End With
               End With
               End With
          End If
         
         With wSh
               LgnDéb = .Cells(.Rows.Count, ColEmployé).End(xlUp).Row     'Première ligne libre dans la colonne Employé
               LgnàCopier = Split(valeurs(n), "¤")                              'Identifier les lignes à copier (l'élément 0 est vide et ne sera pas lu)
               nblgn = UBound(LgnàCopier)
               ReDim tbres(1 To nblgn, 1 To nbcol)                              'Créer un tableau avec les valeurs à copier
               For i = 1 To nblgn
                    For j = 1 To nbcol
                         tbres(i, j) = tbdonnées(LgnàCopier(i), j)
                    Next j
                    DicLgn.Remove LgnàCopier(i)                                 'Retire cette ligne du dictionnaire des lignes à conserver
               Next i
               .Cells(LgnDéb + 1, 1).Resize(nblgn, nbcol).Value = tbres         'Coller les valeur dans la feuille Employé
              
               'Validation des données
               derlgn = .Cells(.Rows.Count, ColEmployé).End(xlUp).Row
               With .Range(.Cells(lgn1 + 1, 1), .Cells(derlgn, 1)).Validation   'de la 1ère ligne de saisie à la dernière (col A)
                    .Delete
                    .Add Type:=xlValidateList, Formula1:="=chx_Ville"           'utilisation du nom défini chx_ville
               End With
              
               With .Range(.Cells(lgn1 + 1, 2), .Cells(derlgn, 2)).Validation   'de la 1ère ligne de saisie à la dernière (col B)
                    .Delete
                    .Add Type:=xlValidateList, Formula1:="=chx_Type"            'utilisation du nom défini chx_type
               End With
              
               'Mettre un format (jjj*  jj/mm/aaa) par exemple en colonne 4
               With .Range(.Cells(lgn1 + 1, 4), .Cells(derlgn, 4))
                    .NumberFormatLocal = "jjj* jj/mm/aaaa"
                    .HorizontalAlignment = xlRight
                    .IndentLevel = 1
               End With
               'format conditionnel pour bordures
               Application.Goto .Cells(lgn1, 1)
               With .Range(.Cells(lgn1, 1), .Cells(.Rows.Count, ColEmployé)).FormatConditions
                    .Delete
                    With .Add(xlExpression, Formula1:="=" & wSh.Cells(lgn1, ColEmployé).Address(False, True, xlA1) & "<>""""")
                         .Borders.LineStyle = xlContinuous
                         .Borders.Color = 12874308
                    End With
               End With
               wShSce.Rows(lgn1).Copy
               .Rows(lgn1).PasteSpecial Paste:=xlPasteColumnWidths
               If Not .AutoFilterMode Then .Cells(lgn1, 1).AutoFilter
         
          End With
     Next
    
     lgnAconserver = DicLgn.Count    'nbre de lignes à conserver restantes
    
     'Constitution d'une tableau des données à conserver
     ReDim tbres(1 To lgnAconserver, 1 To nbcol)
     clefs = DicLgn.Keys: valeurs = DicLgn.Items
     For i = 1 To lgnAconserver
          l = valeurs(i - 1)
          For j = 1 To nbcol
               tbres(i, j) = tbdonnées(l, j)
          Next
     Next
    
     'Effacer les anciennes données et coller les données à conserver
     With wShSce
          .Cells(lgn1, 1).CurrentRegion.ClearContents
          .Cells(lgn1, 1).Resize(lgnAconserver, nbcol) = tbres
          If Not .AutoFilterMode Then .Cells(lgn1, 1).AutoFilter
          .Activate
     End With
     Application.ScreenUpdating = True
     If Texte <> Message Then MsgBox Title:="Création de feuilles employé", Prompt:=Texte

End Sub

Voir la PJ
A bientôt

C'est parfait en tout point et ça correspond vraiment à ce que j'avais besoin. J'ai tout ajusté et insérer dans mon fichier et ça fonctionne nickel. Merci énormément de toute l'aide dans ce dossier. C'est grandement apprécié 🥰

Microsoft 365 Ajout d'onglet par VBA et entête de colonnes

Roseline

XLDnaute Occasionnel

Pièces jointes

AtTheOne

AtTheOne

XLDnaute Accro

AtTheOne

XLDnaute Accro

Pièces jointes

Roseline

XLDnaute Occasionnel

Discussions similaires

Microsoft 365 Ajout d'onglet par VBA et entête de colonnes

Roseline

XLDnaute Occasionnel

Pièces jointes

AtTheOne

XLDnaute Accro

AtTheOne

XLDnaute Accro

Pièces jointes

Roseline

XLDnaute Occasionnel

Discussions similaires

Privacy & Transparency

Privacy & Transparency