Problème avec ActiveSheet.Name = c.Value

[a26]

Bonjour,
Après élaboration d'un fichier d'extraction de données vers plusieurs onglets dont la solution m'avait été donnée par JB, j'ai essayé de le transposer à un autre fichier, mais je bute toujours sur le même problème. La macro exécute le transfert mais celle-ci s'arrête à ActiveSheet.Name = c.Value et chaque fois m'ajoute une feuille supplémentaire.
J'ai remarqué que la ligne R2 de Catégorie ne fonctionnait pas.
Avez-vous une solution à ce problème.
Merci.

 

[gilbert_RGI]

Re : Problème avec ActiveSheet.Name = c.Value

Bonjour,

remplacer

For Each c In f.Range("S2:S" & f.[S65000].End(xlUp).Row)

par

For Each c In f.Range("S2:S" & f.[S65000].End(xlUp).Row - 1)

 

[BOISGONTIER]

Re : Problème avec ActiveSheet.Name = c.Value

Bonjour,

Sub Extrait_1()
  Set f = Sheets("arrivée")
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  '--- Liste des services
  f.[A9:H10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=f.[r1], Unique:=True
  For Each c In f.Range("R2:R" & f.[R65000].End(xlUp).Row)   ' pour chaque service
   If c.Value <> "" Then
     f.[R2] = 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
     [k1] = f.[r1]
     [K2] = c.Value
     [k1:k2].Font.Bold = True
     [k1].Interior.ColorIndex = 36
     '-- extraction
     f.[A9:H10000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[R1:R2], CopyToRange:=[A1]
    End If
   Next c
End Sub

JB

 

[Bebere]

Re : Problème avec ActiveSheet.Name = c.Value

bonjour a26
tu as une erreur lorsque c est vide,un test sur c devrait résoudre le problème

Sub Extrait_1()
  Set f = Sheets("arrivée")
  Application.DisplayAlerts = False
  Application.ScreenUpdating = False
  '--- Liste des services
  f.[A9:H10000].AdvancedFilter Action:=xlFilterCopy, CopyToRange:=f.[r1], Unique:=True
  For Each c In f.Range("R2:R" & f.[R65000].End(xlUp).Row)   ' pour chaque service
   If c <> "" Then
     f.[R2] = 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
     [k1] = f.[r1]
     [K2] = c.Value
     [k1:k2].Font.Bold = True
     [k1].Interior.ColorIndex = 36
     '-- extraction
     f.[A9:H10000].AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=f.[R1:R2], CopyToRange:=[A1]
     End If
   Next c
   
End Sub

edit bonjour à tous

 

[a26]

Re : Problème avec ActiveSheet.Name = c.Value

Bonjour JB et gilbert_RGI,
Je viens de tester avec le code de JB, le résultat est parfait.
Merci à tous les deux pour la solution au problème.
Cordialement,
a26