Je dispose d'une feuille Excel qui contient des noms sur la colonne 2 (avec doublons). je veux créer une macro qui m'insère des nouvelles feuilles avec les noms disponibles(nouvelles feuilles sans doublons).
Après avoir créer ces feuilles par noms, je veux copier les lignes qui correspond à chaque nom. par exemple si la cellule "B2" est égale au nom d'une de ces feuilles récemment crées il y'aura copier/coller de toute la ligne de la feuille source vers sa feuille correspondante jusqu'à cellule non vide.
une dernière question: j'ai des noms qui sont supérieurs à 32 caractères ce qui rend impossible le renommage des feuilles. Existe t'il un code pour retenir que 32 caractères pour les noms qui sont sup ?
ci dessous mon code un peu rectifié:
Code:
Sub Extrait()
Application.DisplayAlerts = False
For i = Sheets.Count To 2 Step -1
Sheets(i).Delete
Next i
Application.DisplayAlerts = True
Worksheets("BD").Range("G2:G" & Range("G65536").End(xlUp).Row).ClearContents 'efface
Worksheets("BD").Select
Range("A1").Select
Range("B1:B" & Range("A65536").End(xlUp).Row).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Worksheets("BD").Range("G1"), Unique:=True
Set f = Sheets("BD")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For Each c In f.Range("G2:G" & f.[G65000].End(xlUp).Row) ' pour chaque service
f.[G2] = c.Value
On Error Resume Next
Sheets(c.Value).Delete
On Error GoTo 0
Sheets.Add After:=Sheets(Sheets.Count) ' création
ActiveSheet.Name = c.Value
'-- extraction
f.[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[G1:G2], CopyToRange:=[A1]
Next c
End Sub
Sub Extrait()
Set f = Sheets("BD")
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'--- Liste des noms
f.[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=f.[G1], Unique:=True
For Each c In f.Range("G2:G" & f.[G65000].End(xlUp).Row) ' pour chaque nom
tmp = Left(c.Value, 31)
f.[G2] = tmp & "*"
On Error Resume Next
Sheets(tmp).Delete
On Error GoTo 0
Sheets.Add After:=Sheets(Sheets.Count) ' création
ActiveSheet.Name = tmp
'-- extraction
f.[A1:D10000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[G1:G2], CopyToRange:=[A1]
Next c
End Sub