Boostez vos compétences Excel avec notre communauté !
Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !
Function FeuilleExiste(wk As Workbook, stFeuille) As Boolean
On Error Resume Next
FeuilleExiste = Not (wk.Sheets(stFeuille) Is Nothing)
End Function
'compte le nombre de lignes de données par prénom
Function Nbre_Ligne_Nom(Onglet As String, Compt As Integer) As Integer
Dim St As String
St = Sheets("Données").Range("A" & Compt).Value
While St = Onglet
Compt = Compt + 1
St = Sheets("Données").Range("A" & Compt).Value
Wend
Nbre_Ligne_Nom = Compt - 1
End Function
Sub Traite_Donnée(Onglet As String, Compt As Integer)
Dim Fin As Integer, Debut As Integer
Sheets(Onglet).Activate
Range("A2").Value = Sheets("Données").Range("B" & Compt).Value
Range("A2").Font.Bold = True
Range("A3").Value = Sheets("Données").Range("C" & Compt).Value
Range("A5").Value = Sheets("Données").Range("A" & Compt).Value
Range("A5").Font.Bold = True
Sheets("Données").Activate
Range("D1:M1").Select
Application.CutCopyMode = False
Selection.Copy
Sheets(Onglet).Activate
Range("A6").Select
ActiveSheet.Paste
Selection.Font.Bold = True
Selection.Interior.ColorIndex = 46
'première ligne pour un prénom
Debut = Compt
'dernière ligne pour un prénom
Fin = Nbre_Ligne_Nom(Onglet, Compt)
'Copier coller de données vers les autres feuilles
Sheets("Données").Activate
Range("D" & Debut & ":M" & Fin).Select
Selection.Copy
Sheets(Onglet).Activate
Range("A7").Select
ActiveSheet.Paste
Range("A1").Select
End Sub
Public Sub Test()
Dim Onglet As String
Dim Compt As Integer
'boucle sur les prénoms
Compt = 2
Onglet = Sheets("Données").Range("A" & Compt).Value
While Onglet <> ""
If Not FeuilleExiste(ThisWorkbook, Onglet) Then
Worksheets.Add.Name = Onglet
Sheets(Onglet).Move After:=Sheets(Sheets.Count)
Call Traite_Donnée(Onglet, Compt)
End If
Onglet = Sheets("Données").Range("A" & Compt).Value
Wend
End Sub
Sub CreationOnglet()
Dim O As Integer
Dim Max As Integer
Dim Ws As Worksheet
Dim Debut As Integer, Fin As Integer
Dim Onglet As String
Application.ScreenUpdating = False
Set Ws = Sheets("Données")
Sheets("Données").Activate
Max = Range("A" & Rows.Count).End(xlUp).Row
For O = 2 To Max
If Not ExisteFeuille(Ws.Range("A" & O).Text) Then
Sheets.Add after:=Sheets(Sheets.Count)
Onglet = Ws.Range("A" & O)
ActiveSheet.Name = Onglet
Sheets("Modèle").Cells.Copy Destination:=Range("A1")
Range("A5") = Ws.Range("A" & O)
Range("A2") = Ws.Range("B" & O)
Range("A3") = Ws.Range("C" & O)
Debut = O
Fin = Nbre_Ligne_Nom(Onglet, Debut)
Sheets("Données").Activate
Range("D" & Debut & ":M" & Fin).Select
Selection.Copy
Sheets(Onglet).Activate
Range("A7").Select
ActiveSheet.Paste
Range("A1").Select
End If
Next O
Ws.Select
Application.ScreenUpdating = True
End Sub
Sub CreationOnglet()
Dim O As Integer
Dim Max As Integer
Dim Ws As Worksheet
Dim Debut As Integer, Fin As Integer
Dim Onglet As String
Application.ScreenUpdating = False
Set Ws = Sheets("Données")
Sheets("Données").Activate
Max = Range("A" & Rows.Count).End(xlUp).Row
For O = 2 To Max
If Not ExisteFeuille(Ws.Range("A" & O).Text) Then
Sheets.Add after:=Sheets(Sheets.Count)
Onglet = Ws.Range("A" & O)
ActiveSheet.Name = Onglet
Sheets("Modèle").Cells.Copy Destination:=Range("A1")
Range("A5") = Ws.Range("A" & O)
Range("A2") = Ws.Range("B" & O)
Range("A3") = Ws.Range("C" & O)
Debut = O
Fin = Nbre_Ligne_Nom(Onglet, Debut)
Sheets("Données").Activate
Range("D" & Debut & ":M" & Fin).Select
Selection.Copy
Sheets(Onglet).Activate
Range("A7").Select
ActiveSheet.Paste
Range("A1").Select
End If
Next O
Ws.Select
Application.ScreenUpdating = True
End Sub
'compte le nombre de lignes de données par prénom
Function Nbre_Ligne_Nom(Onglet As String, Compt As Integer) As Integer
Dim St As String
St = Sheets("Données").Range("A" & Compt).Value
While St = Onglet
Compt = Compt + 1
St = Sheets("Données").Range("A" & Compt).Value
Wend
Nbre_Ligne_Nom = Compt - 1
End Function
Function ExisteFeuille(Nom As String) As Boolean
' retourne True ou False qui indique la présence ou l'absence de la feuille
On Error Resume Next
ExisteFeuille = Sheets(Nom).Name <> ""
On Error GoTo 0
End Function
Option Explicit
Sub Test()
'Dans VBA, menu Outils/références, cochez Microsoft Scripting Runtime.
Dim Dico As Dictionary, cel As Range, connue As Worksheet, Tablo, Tablo1()
Dim i As Long, k As Long, x As Long, NouvelleFeuille As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dico = New Dictionary
'Suppression de toutes les feuilles sauf la 1ère
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
'Boucle sur toutes les lignes remplies de la colonne A - A partir de A2
With Feuil1
For Each cel In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
'Mise en mémoire des noms des onglets à créer
If Not Dico.Exists(cel.Value) Then Dico.Add cel.Value, Array(cel, cel.Offset(0, 1), cel.Offset(0, 2))
Next cel
Tablo = .Range("A2:M" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
'Boucle sur toutes les noms en mémoire et création de la feuille
For i = 0 To Dico.Count - 1
For k = LBound(Tablo, 1) To UBound(Tablo, 1)
If Tablo(k, 1) = Dico.Keys(i) Then
x = x + 1
ReDim Preserve Tablo1(1 To 10, 1 To x)
Tablo1(1, x) = Tablo(k, 4)
Tablo1(2, x) = Tablo(k, 5)
Tablo1(3, x) = Tablo(k, 6)
Tablo1(4, x) = Tablo(k, 7)
Tablo1(5, x) = Tablo(k, 8)
Tablo1(6, x) = Tablo(k, 9)
Tablo1(7, x) = Tablo(k, 10)
Tablo1(8, x) = Tablo(k, 11)
Tablo1(9, x) = Tablo(k, 12)
Tablo1(10, x) = Tablo(k, 13)
End If
Next k
NouvelleFeuille = Dico.Items(i)(0)
On Error Resume Next
Set connue = Sheets(NouvelleFeuille)
If Err <> 0 Then Sheets.Add.Name = NouvelleFeuille
On Error GoTo 0
'Avec la feuille créée
With Sheets(NouvelleFeuille)
'On copie les intitulés
.Cells(2, 1).Value = Dico.Items(i)(1)
.Cells(3, 1).Value = Dico.Items(i)(2)
.Cells(5, 1).Value = Dico.Items(i)(0)
.Cells(6, 1).Resize(1, 10) = Array("N° Item", "N° Cas Type", "Date", _
"Code Mesure", "Poids", "Résultat corrigé", "Résultat", "Minimum", _
"Maximum", "Code unité")
.Cells(6, 1).Resize(1, 10).Interior.ColorIndex = 43
'On complète le tableau avec les données correspondantes à chacun
.Cells(7, 1).Resize(UBound(Tablo1, 2), UBound(Tablo1, 1)) = Application.Transpose(Tablo1)
End With
Erase Tablo1: x = 0
'On passe à la feuille suivante
Next i
Sheets("Données").Move Sheets(1)
Sheets("Données").Select
Set Dico = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Function Nbre_Ligne_Nom(Onglet As String, [B]ByVal [/B]Compt As Integer) As Integer
Dim St As String
Dim Init As Integer
St = Sheets("Données").Range("A" & Compt).Value
Init = Compt
While St = Onglet
Compt = Compt + 1
St = Sheets("Données").Range("A" & Compt).Value
Wend
Nbre_Ligne_Nom = Compt - Init
End Function
Debut = O
Fin = Debut + Nbre_Ligne_Nom(Onglet, Debut) - 1
Sheets("Données").Activate
Range("D" & Debut & ":M" & Fin).Select
Option Explicit
Sub Test()
'Dans VBA, menu Outils/références, cochez Microsoft Scripting Runtime.
Dim Dico As Dictionary, cel As Range, Tablo, Tablo1()
Dim i As Long, j As Long, k As Long, x As Long, NouvelleFeuille As String
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set Dico = New Dictionary
'Suppression de toutes les feuilles sauf la 1ère et la 2ème
For i = Sheets.Count To 3 Step -1
Sheets(i).Delete
Next i
'Boucle sur toutes les lignes remplies de la colonne A - A partir de A2
With Feuil6
For Each cel In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
'Mise en mémoire des noms des onglets à créer
If Not Dico.Exists(cel.Value) Then Dico.Add cel.Value, Array(cel, cel.Offset(0, 1), cel.Offset(0, 2))
Next cel
Tablo = .Range("A2:M" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
'Boucle sur toutes les noms en mémoire et création de la feuille
For i = 0 To Dico.Count - 1
For k = LBound(Tablo, 1) To UBound(Tablo, 1)
If Tablo(k, 1) = Dico.Keys(i) Then
x = x + 1
ReDim Preserve Tablo1(1 To 10, 1 To x)
For j = 1 To 10
Tablo1(j, x) = Tablo(k, j + 3)
Next j
End If
Next k
On Error Resume Next
NouvelleFeuille = Dico.Items(i)(0)
If Err = 0 Then
Sheets("Modèle").Copy after:=Sheets(Sheets.Count)
Sheets(Sheets.Count).Name = NouvelleFeuille
End If
On Error GoTo 0
'Avec la feuille créée
With Sheets(NouvelleFeuille)
'On copie les intitulés
.Cells(2, 1).Value = Dico.Items(i)(1)
.Cells(3, 1).Value = Dico.Items(i)(2)
.Cells(5, 1).Value = Dico.Items(i)(0)
'On complète le tableau avec les données correspondantes à chacun
.Cells(7, 1).Resize(UBound(Tablo1, 2), UBound(Tablo1, 1)) = Application.Transpose(Tablo1)
End With
Erase Tablo1: x = 0
'On passe à la feuille suivante
Next i
Sheets("Données").Move Sheets(1)
Sheets("Données").Select
Set Dico = Nothing
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Sub Test()
'Dans VBA, menu Outils/références, cochez Microsoft Scripting Runtime.
Dim Mondico As Dictionary, Tablo()
Dim DLig As Long, DLig1 As Long, DCol As Byte, i As Long
Dim NomOnglet As String
Application.ScreenUpdating = False
Set Mondico = New Dictionary
With Feuil1
DLig = .Range("A" & Rows.Count).End(xlUp).Row
DCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For Each cel In .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
'Mise en mémoire des noms des onglets à créer
If Not Mondico.Exists(cel.Value) Then Mondico.Add cel.Value, Array(cel, cel.Offset(0, 1), cel.Offset(0, 2))
Next cel
Tablo = Mondico.Keys
For i = 0 To Mondico.Count - 1
NomOnglet = Tablo(i)
If FeuilleExiste(NomOnglet) = False Then
Sheets.Add after:=Sheets(Sheets.Count)
With ActiveSheet
.Name = NomOnglet
.Cells(2, 1).Value = Mondico.Items(i)(1)
.Cells(3, 1).Value = Mondico.Items(i)(2)
.Cells(5, 1).Value = Mondico.Items(i)(0)
.Cells(6, 1).Resize(1, 10) = Array("N° Item", "N° Cas Type", "Date", _
"Code Mesure", "Poids", "Résultat corrigé", "Résultat", "Minimum", _
"Maximum", "Code unité")
.Cells(6, 1).Resize(1, 10).Interior.ColorIndex = 43
End With
ElseIf Not IsEmpty(Sheets(NomOnglet).Range("A7")) Then
DLig1 = Sheets(NomOnglet).Range("A" & Rows.Count).End(xlUp).Row
Sheets(NomOnglet).Range("A7:J" & DLig1).ClearContents
Else
'''
End If
Next i
Set Mondico = Nothing
For i = 2 To DLig
NomOnglet = .Cells(i, 1)
.Range(.Cells(i, 4), .Cells(i, DCol)).Copy Destination:=Sheets(NomOnglet).Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next i
End With
Application.ScreenUpdating = True
End Sub
Function FeuilleExiste(nom As String) As Boolean
On Error Resume Next
FeuilleExiste = Sheets(nom).Name <> ""
On Error GoTo 0
End Function
We use cookies and similar technologies for the following purposes:
Est ce que vous acceptez les cookies et ces technologies?
We use cookies and similar technologies for the following purposes:
Est ce que vous acceptez les cookies et ces technologies?