Création onglets
Bonjour,
Je fais appel à ce forum car j'ai besoin d'aide pour créer un code vba.
Ci-joint vous trouverez le fichier avec les donnes à manipuler.
Je dispose d'une d'une feuille nommée Récap, avec les données initiales.
J'aimerai créer une macro qui crée suivant une colonne définie autant d'onglet qu'il y a de modalités dans cette colonne.
Je pense qu'il faudrai la créer en 3 étapes :
1) Un formulaire qui demande à l'utilisateur quelle est la colonne qu'il veux se servir pour créer les onglets. L'utilisateur donne le nom de la colonne, ou le numéro de colonne, quelque chose comme ça...
2) La macro crée les différents onglets suivant les modalités de la colonne.
3) La macro renomme les onglets comme les modalités.
Par exemple :
Dans le fichier joint, j'ai la feuille récap avec 3 variables : pays, ville et age.
Je veux créer un onglet par modalité de la colonne "Pays".
J'ai donc créer un onglet France, Espagne, Italie, Portugal qui reprend l'ensemble des informations des 3 variable mais que pour le pays concerné.
J'espère avoir été assez clair ! Je reste disponible pour toutes vos questions !
Merci d'avance pour vos réponses !
Cordialement,
Bonjour,
Je vous remercie de votre réponse, cela correspond à ce que je voulais.
Cependant cette macro est utilisable qu'avec des tableaux à 3 colonnes, est ce qu'il serait possible de le généraliser pour pouvoir prendre en charge plusieurs colonnes ?
De ce fait est ce qu'on pourrait déplacer les cellules ("F1:F2") qui sont utiliser par la macro, vers une autre feuille par exemple ?
Je vous remercie d'avance pour votre aide.
Cordialement,
Bonjour
Des commentaires dans le code qui te permettront de déplacer la zone des critères
Merci,
J'ai réussit à modifier un peu le code pour l'adapter cependant il y a une partie que je ne sais pas comment écrire.
Voici le code ci- dessous.
La partie est celle ci :
Ws.Range(NbCl & NbLg).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Sheets("recap").Range("F1:F2"), copytorange:=.Range("A1:C1")
Merci d'avance pour votre aide.
Cordialement,
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim Mondico As Object
Dim J As Long, NbLg As Long, NbCl As Long, Crit As Long
Dim I As Integer
Dim Tablo
Dim Ws As Worksheet
If Not Intersect(Rows(1), Target) Is Nothing And Target <> "" Then
Application.ScreenUpdating = False
Cancel = True
Set Ws = ActiveSheet
NbLg = Range("A" & Rows.Count).End(xlUp).Row
NbCl = Cells(1, Columns.Count).End(xlToLeft).Column
' 1ère cellule de la zone de critères à inserer apres la derniere colonne, ligne 1
Crit = NbCl + 1
Cells(1, Crit) = Target
Set Mondico = CreateObject("Scripting.dictionary")
For J = 2 To NbLg
If Cells(J, Target.Column) <> "" Then
Mondico(Cells(J, Target.Column).Value) = ""
End If
Next J
If Mondico.Count = 0 Then Exit Sub
Tablo = Mondico.keys
For I = 0 To UBound(Tablo)
' 2ème cellule de la zone de critères à inserer apres la derniere colonne, ligne 2
Cells(2, Crit) = Tablo(I)
If FeuilleExiste(CStr(Tablo(I))) = False Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = Tablo(I)
End If
With Sheets(CStr(Tablo(I)))
.Cells.Clear
' criteriarange:=Sheets("recap").Range("F1:F2") ' zone des critères
Ws.Range(NbCl & NbLg).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Sheets("recap").Range("F1:F2"), copytorange:=.Range("A1:C1")
End With
Next I
With Ws
.Range("F1:F2").ClearContents
.Select
End With
End If
End Sub
Function FeuilleExiste(Nom As String) As Boolean
On Error Resume Next
FeuilleExiste = Sheets(Nom).Name <> ""
On Error GoTo 0
End Function
Bonjour
Voir le fichier
Attention: Le reste de la ligne 1 doit être vide
A tester
Merci beaucoup !
A bientôt !
Cordialement.