'______________________________________________________
'FONCTION DE VERIFICATION DE L'EXISTENCE D'UNE FEUILLE
'======================================================
Function FeuilleExiste(Nom$)
Dim sh As Worksheet
On Error Resume Next
Set sh = ThisWorkbook.Worksheets(Nom) 'tente d'accéder à la feuille "Nom"
On Error GoTo 0
FeuilleExiste = Not sh Is Nothing 'la feuille "Nom" existe si sh n'est pas Nothing
End Function
Const lgn1 = 4 'ligne de départ
'______________________________________________________
'AJOUTER DES COLONNES A LA FEUILLE "Suivi des dossiers"
'======================================================
Sub CréerColonnes()
Dim wSh As Worksheet, derlgn As Long
Application.ScreenUpdating = False
Set wSh = ShSuivi
With wSh
'Effacer les filtres
If .FilterMode Then .ShowAllData
.AutoFilterMode = False
derlgn = .Cells(.Rows.Count, 1).End(xlUp).Row
If derlgn < lgn1 Then Exit Sub
'Insertion d'une colonne en 2ième position
.Columns(2).Insert
.Cells(lgn1, 2) = "Résultat"
'Insertion de 3 colonnes en tête
.Columns(1).Resize(, 3).Insert
.Cells(lgn1, 1) = "Ville"
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
.Cells(lgn1, 2) = "Type d'achat"
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
.Cells(lgn1, 3) = "# facture"
'Mettre un format (jjj jj/mm/aaa) par exemple en colonne 4
.Range(.Cells(lgn1 + 1, 4), .Cells(derlgn, 4)).NumberFormatLocal = "jjj jj/mm/aaaa"
'Activer les filtres
.Cells(lgn1, 1).AutoFilter
End With
Application.ScreenUpdating = True
End Sub
'________________________________________________________
'CREATION DES FEUILLES EMPLOYE AVEC TRANSFERT DES DONNEES
'========================================================
Sub CréerFeuillesEmployés()
Dim wShSce As Worksheet, wSh As Worksheet
Dim Dico As Object, DicLgn As Object
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
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à
MsgBox Title:="Employé " & clef, prompt:="Une feuille à ce nom existe déjà"
Else
Set wSh = ThisWorkbook.Worksheets.Add(before:=shDonnées) 'Création de la feuille Employé
With wSh
.Name = clef 'Attribution du nom
.Cells(lgn1, 1).Resize(1, nbcol).Value = TitresCol 'Coller les titres de colonne
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(lgn1 + 1, 1).Resize(nblgn, nbcol).Value = tbres 'Coller les valeur dans la feuille Employé
wShSce.Rows(lgn1).Copy
.Rows(lgn1).PasteSpecial Paste:=xlPasteColumnWidths
If Not .AutoFilterMode Then .Cells(lgn1, 1).AutoFilter
End With
End If
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
End Sub
Bonjour,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 à transférer pour chaque employé (Scripting.Dictionary).
Pour ces 2 Subs une constante lgn1 définie la 1ere ligne du tableau de données.
Code Fonction FeuilleExiste(Nom)
VB:'______________________________________________________ 'FONCTION DE VERIFICATION DE L'EXISTENCE D'UNE FEUILLE '====================================================== Function FeuilleExiste(Nom$) Dim sh As Worksheet On Error Resume Next Set sh = ThisWorkbook.Worksheets(Nom) 'tente d'accéder à la feuille "Nom" On Error GoTo 0 FeuilleExiste = Not sh Is Nothing 'la feuille "Nom" existe si sh n'est pas Nothing End Function
Code Sub CréerColonnes()
VB:Const lgn1 = 4 'ligne de départ '______________________________________________________ 'AJOUTER DES COLONNES A LA FEUILLE "Suivi des dossiers" '====================================================== Sub CréerColonnes() Dim wSh As Worksheet, derlgn As Long Application.ScreenUpdating = False Set wSh = ShSuivi With wSh 'Effacer les filtres If .FilterMode Then .ShowAllData .AutoFilterMode = False derlgn = .Cells(.Rows.Count, 1).End(xlUp).Row If derlgn < lgn1 Then Exit Sub 'Insertion d'une colonne en 2ième position .Columns(2).Insert .Cells(lgn1, 2) = "Résultat" 'Insertion de 3 colonnes en tête .Columns(1).Resize(, 3).Insert .Cells(lgn1, 1) = "Ville" 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 .Cells(lgn1, 2) = "Type d'achat" 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 .Cells(lgn1, 3) = "# facture" 'Mettre un format (jjj jj/mm/aaa) par exemple en colonne 4 .Range(.Cells(lgn1 + 1, 4), .Cells(derlgn, 4)).NumberFormatLocal = "jjj jj/mm/aaaa" 'Activer les filtres .Cells(lgn1, 1).AutoFilter End With Application.ScreenUpdating = True End Sub
code Sub CréerFeuillesEmployés()
VB:'________________________________________________________ 'CREATION DES FEUILLES EMPLOYE AVEC TRANSFERT DES DONNEES '======================================================== Sub CréerFeuillesEmployés() Dim wShSce As Worksheet, wSh As Worksheet Dim Dico As Object, DicLgn As Object 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 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à MsgBox Title:="Employé " & clef, prompt:="Une feuille à ce nom existe déjà" Else Set wSh = ThisWorkbook.Worksheets.Add(before:=shDonnées) 'Création de la feuille Employé With wSh .Name = clef 'Attribution du nom .Cells(lgn1, 1).Resize(1, nbcol).Value = TitresCol 'Coller les titres de colonne 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(lgn1 + 1, 1).Resize(nblgn, nbcol).Value = tbres 'Coller les valeur dans la feuille Employé wShSce.Rows(lgn1).Copy .Rows(lgn1).PasteSpecial Paste:=xlPasteColumnWidths If Not .AutoFilterMode Then .Cells(lgn1, 1).AutoFilter End With End If 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 End Sub
Voilà, voir le fichier joint
A bientôt
Rebonjour,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 à transférer pour chaque employé (Scripting.Dictionary).
Pour ces 2 Subs une constante lgn1 définie la 1ere ligne du tableau de données.
Code Fonction FeuilleExiste(Nom)
VB:'______________________________________________________ 'FONCTION DE VERIFICATION DE L'EXISTENCE D'UNE FEUILLE '====================================================== Function FeuilleExiste(Nom$) Dim sh As Worksheet On Error Resume Next Set sh = ThisWorkbook.Worksheets(Nom) 'tente d'accéder à la feuille "Nom" On Error GoTo 0 FeuilleExiste = Not sh Is Nothing 'la feuille "Nom" existe si sh n'est pas Nothing End Function
Code Sub CréerColonnes()
VB:Const lgn1 = 4 'ligne de départ '______________________________________________________ 'AJOUTER DES COLONNES A LA FEUILLE "Suivi des dossiers" '====================================================== Sub CréerColonnes() Dim wSh As Worksheet, derlgn As Long Application.ScreenUpdating = False Set wSh = ShSuivi With wSh 'Effacer les filtres If .FilterMode Then .ShowAllData .AutoFilterMode = False derlgn = .Cells(.Rows.Count, 1).End(xlUp).Row If derlgn < lgn1 Then Exit Sub 'Insertion d'une colonne en 2ième position .Columns(2).Insert .Cells(lgn1, 2) = "Résultat" 'Insertion de 3 colonnes en tête .Columns(1).Resize(, 3).Insert .Cells(lgn1, 1) = "Ville" 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 .Cells(lgn1, 2) = "Type d'achat" 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 .Cells(lgn1, 3) = "# facture" 'Mettre un format (jjj jj/mm/aaa) par exemple en colonne 4 .Range(.Cells(lgn1 + 1, 4), .Cells(derlgn, 4)).NumberFormatLocal = "jjj jj/mm/aaaa" 'Activer les filtres .Cells(lgn1, 1).AutoFilter End With Application.ScreenUpdating = True End Sub
code Sub CréerFeuillesEmployés()
VB:'________________________________________________________ 'CREATION DES FEUILLES EMPLOYE AVEC TRANSFERT DES DONNEES '======================================================== Sub CréerFeuillesEmployés() Dim wShSce As Worksheet, wSh As Worksheet Dim Dico As Object, DicLgn As Object 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 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à MsgBox Title:="Employé " & clef, prompt:="Une feuille à ce nom existe déjà" Else Set wSh = ThisWorkbook.Worksheets.Add(before:=shDonnées) 'Création de la feuille Employé With wSh .Name = clef 'Attribution du nom .Cells(lgn1, 1).Resize(1, nbcol).Value = TitresCol 'Coller les titres de colonne 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(lgn1 + 1, 1).Resize(nblgn, nbcol).Value = tbres 'Coller les valeur dans la feuille Employé wShSce.Rows(lgn1).Copy .Rows(lgn1).PasteSpecial Paste:=xlPasteColumnWidths If Not .AutoFilterMode Then .Cells(lgn1, 1).AutoFilter End With End If 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 End Sub
Voilà, voir le fichier joint
A bientôt
Rebonjour,Bonjour,
Merci pour le retour !
Je vais faire le transfert dans la feuille existante quand elle existe, mais juste une question :si l'onglet de mon employé est déjà existant mais que je veux transférer les nouvelles données sans créer un autre onglet, comment je peux ajouter cela à la VBA
Oups !quand je crée les nouveaux onglets, les menus déroulant disparaissent
Allo, aucun écrasement d'anciennes données. C'est justement si je dois en ajouter. Les données déjà là doivent demeurer. Aussi, j'aimerais copier les boutons dans tous les onglets en même temps que la création des onglets. Je pourrai ajuster selon mon besoin. Tu es super gentil de m'aiderBonjour à toutes & à tous, bonjour @Roseline
Je vais faire le transfert dans la feuille existante quand elle existe, mais juste une question :
Faut-il ajouter les lignes transférées à la fin des feuilles préexistantes (conserver les anciennes données) ou supprimer les anciens transfert et recommencer à la ligne 2 ?
Oups !J'ai oublié les validation de données dans les nouveaux onglets !
Je reprends le code VBA dès que tu me réponds sur l'écrasement ou non des anciennes données ...*
A bientôt
De quelles actions à tu besoin dans les feuilles "Employé" ?j'aimerais copier les boutons dans tous les onglets en même temps que la création des onglets. Je pourrai ajuster selon mon besoin
Allo,Re
De quelles actions à tu besoin dans les feuilles "Employé" ?
A tout de suite ...
- Pas la création des feuilles j'imagine
- Pas l'ajout des colonnes, à moins que tu ne l'aies oubliée avant de créer tes feuilles "Employé" (
Oups j'ai oublié ! tant pis je le fais après ...) - L'import, pour faire des import de ligne individuellement sur certaines feuilles "Employé"
Const lgn1 = 4 'ligne de départ
'======================================================
'AJOUTER DES COLONNES A LA FEUILLE "Suivi des dossiers"
'======================================================
Sub CréerColonnes()
Dim wSh As Worksheet, derlgn As Long
Application.ScreenUpdating = False
Set wSh = ShSuivi
With wSh
'Effacer les filtres
If .FilterMode Then .ShowAllData
.AutoFilterMode = False
derlgn = .Cells(.Rows.Count, 1).End(xlUp).Row
If derlgn < lgn1 Then Exit Sub
'Insertion d'une colonne en 2ième position
.Columns(2).Insert
.Cells(lgn1, 2) = "Résultat"
'Insertion de 3 colonnes en tête
.Columns(1).Resize(, 3).Insert
'Validation des données
.Cells(lgn1, 1) = "Ville"
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
.Cells(lgn1, 2) = "Type d'achat"
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
.Cells(lgn1, 3) = "# facture"
'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
.Cells(lgn1, 1).Activate
ColEmployé = WorksheetFunction.Match("Employé", .Rows(lgn1), 0)
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
'Activer les filtres
.Cells(lgn1, 1).AutoFilter
End With
Application.ScreenUpdating = True
End Sub
'=====================================================================================
'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
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
.Cells(lgn1, 1).Activate
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
'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
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
wowo quel boulot tu as fait c'est tout simplement magique. J'ai adapté tout cela et sérieux c'est incroyable. Il y a seulement un point ou ca bloque, quand l'onglet de l'employé est créé et que je tente un nouveau transfert la vba arrête à cet endroit :Re, il se fait tard !
En pièce jointe le classeur modifier.
- La macro de création et transfert de lignes vérifie l'existence de la feuille "Employé" et la crée éventuellement.
- Le transfert les données s'effectue ensuite sur cette feuille employé en ajout des lignes préexistantes (ou non).
- Un bouton est ajouté, il est lié à la macro "InsérerLigne" à développer.
- Les validations de données sont actives sur les feuilles crées
- Une Mise en Forme Conditionnelle à été ajoutée pour le quadrillage.
Nouveaux codes :
VB:Const lgn1 = 4 'ligne de départ '====================================================== 'AJOUTER DES COLONNES A LA FEUILLE "Suivi des dossiers" '====================================================== Sub CréerColonnes() Dim wSh As Worksheet, derlgn As Long Application.ScreenUpdating = False Set wSh = ShSuivi With wSh 'Effacer les filtres If .FilterMode Then .ShowAllData .AutoFilterMode = False derlgn = .Cells(.Rows.Count, 1).End(xlUp).Row If derlgn < lgn1 Then Exit Sub 'Insertion d'une colonne en 2ième position .Columns(2).Insert .Cells(lgn1, 2) = "Résultat" 'Insertion de 3 colonnes en tête .Columns(1).Resize(, 3).Insert 'Validation des données .Cells(lgn1, 1) = "Ville" 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 .Cells(lgn1, 2) = "Type d'achat" 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 .Cells(lgn1, 3) = "# facture" '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 .Cells(lgn1, 1).Activate ColEmployé = WorksheetFunction.Match("Employé", .Rows(lgn1), 0) 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 'Activer les filtres .Cells(lgn1, 1).AutoFilter End With Application.ScreenUpdating = True End Sub
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 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 .Cells(lgn1, 1).Activate 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 '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 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
A bientôt
Oui, c'est parce-que la feuille n'est pas la feuille active, dans ce cas on ne peut pas activer une de ses cellules.As-tu une idée
Encore wow, c'est fantastique, j'ai tout adapté cela à mon fichier et sérieux c'est de la bombe. Une dernière chose par contre, c'est que le "Set Shp = .Shapes.AddShape(msoShape" se refait à chaque transfert de données, j'aimerais qu'il se crée une fois mais pas à tous les transferts de données et là j'ai encore une fois besoin de ton aide.Bonjour à toutes et à tous, bonjour @Roseline
Oui, c'est parce-que la feuille n'est pas la feuille active, dans ce cas on ne peut pas activer une de ses cellules.
J'ai remplacé .Cells(lgn1, 1).Activate par Application.Goto.Cells(lgn1, 1)
A bientôt
le "Set Shp = .Shapes.AddShape(msoShape" se refait à chaque transfert de données,