VBA - Creation de nouvel onglet pour chaque nouveau noms d'une liste

Bonjour à tous,

J'ai créé une macro qui ne fonctionne qu'à moitié.

Ma requête est la suivante:

Création d'un nouvel onglet pour chaque nom contenu dans un fichier source, en colonne A, avec nom de l'onglet corresponds à ce nom, et récuperation de toutes les lignes contenues dans ce fichier.

(Dans le but de créer une feuille de présence mensuelle pour chaque personne)

Ma macro ne fonctionne qu'avec le premier nom et ne créé pas les onglets pour les noms suivants.

Aussi, la premiere ligne de ce tableau correspond aux titres des colonnes ne sont pas recopiées.

Voiçi la macro utilisée:

Sub CreateSheets()
Dim i As Integer
Dim ws As Worksheet
Dim newSheet As Worksheet
Set ws = ActiveSheet
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set newSheet = Sheets(ws.Cells(i, 1).Value)
On Error GoTo 0
If newSheet Is Nothing Then
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
newSheet.Name = ws.Cells(i, 1).Value
End If
ws.Range("A1").AutoFilter Field:=1, Criteria1:=ws.Cells(i, 1).Value
ws.Range("A1").CurrentRegion.Offset(1, 0).Copy Destination:=newSheet.Range("A1")
ws.AutoFilterMode = False
Next i
End Sub

Edit modo : code à mettre entre balises avec le bouton </> merci d'y faire attention la prochaine fois

Merci de me dire où vous voyez l'erreur

Bonjour Sebb,

Juste un petit oubli, la réinitialisation de la variable objet test

Sub CreateSheets()
  Dim i As Integer
  Dim ws As Worksheet
  Dim newSheet As Worksheet
  Set ws = ActiveSheet
  For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
    On Error Resume Next
    Set newSheet = Sheets(ws.Cells(i, 1).Value)
    On Error GoTo 0
    If newSheet Is Nothing Then
      Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
      newSheet.Name = ws.Cells(i, 1).Value
    End If
    ws.Range("A1").AutoFilter Field:=1, Criteria1:=ws.Cells(i, 1).Value
    ws.Range("A1").CurrentRegion.Offset(1, 0).Copy Destination:=newSheet.Range("A1")
    ws.AutoFilterMode = False
    ' Effacer la variable objet NewSheet
    Set newSheet = Nothing
  Next i
End Sub

A+

Merci Bruno,

J'ai rectifié et l'ai relancé, mais bug:

T'aurais une idée?

Mais le problème de l'ajout de la premiere ligne du tableau persiste.

Bug dès le lancement:

Sub CreateSheets()
Dim i As Integer
Dim ws As Worksheet
Dim newSheet As Worksheet
Set ws = ActiveSheet
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set newSheet = Sheets(ws.Cells(i, 1).Value)
On Error GoTo 0
If newSheet Is Nothing Then
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
newSheet.Name = ws.Cells(i, 1).Value
End If
ws.Range("A1").AutoFilter Field:=1, Criteria1:=ws.Cells(i, 1).Value
ws.Range("A1").CurrentRegion.Offset(1, 0).Copy Destination:=newSheet.Range("A2")
ws.AutoFilterMode = False
' Effacer la variable objet NewSheet
Set newSheet = Nothing
Next i
Dim i As Integer
Dim ws As Worksheet
Dim newSheet As Worksheet
Set ws = ActiveSheet
For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
On Error Resume Next
Set newSheet = Sheets(ws.Cells(i, 1).Value)
On Error GoTo 0
If newSheet Is Nothing Then
Set newSheet = Sheets.Add(After:=Sheets(Sheets.Count))
newSheet.Name = ws.Cells(i, 1).Value
End If
ws.Range("A1").AutoFilter Field:=1, Criteria1:=ws.Cells(i, 1).Value
ws.Range("A1").CurrentRegion.Offset(1, 0).Copy Destination:=newSheet.Range("A1")
ws.AutoFilterMode = False
' Effacer la variable objet NewSheet
Set newSheet = Nothing
Next i

End Sub

Edit modo : code à mettre entre balises avec le bouton </> merci d'y faire attention la prochaine fois

Bonsoir,

Pour commencer 2ème et dernière fois que je mets votre code entre balises, la prochaine je supprimer purement et simplement

Ensuite, votre code est à remplacer par celui que j'ai donné, il en faut pas mettre les 2... quelle idée

Bonne soirée

Probleme résolu !

Merci

Re,