Boucle ne fonctionne pas

Bonjour à tous,

Ci-dessous mon code pour effectuer une boucle sur une plage de donnée (chaque cellule est le nom d'une plage)

Sub AllColleEtSauve()

Dim AllServ As String

Dim Cell As Range

For Each Cell In Range("SERVICES")

LaDate = Day(Date) & "-" & Month(Date) & "-" & Year(Date) 'Variable qui prend la date du jour format aaaa-m-j

Range(Cell).Copy

Workbooks.Add 'Ouvre un nouveau Fichier XL

Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Selection.PasteSpecial 8

Next Cell

End Sub

Cela marche uniquement pour la première cellule, je ne comprends pas...

Merci pour votre aide et idées.

Bonjour,

Un essai :

Sub AllColleEtSauve()

Dim AllServ As String, Cellule As Range, LaDate As String
For Each Cellule In Range("SERVICES")
    LaDate = Format(Date, "YYYY-M-D")
    Workbooks.Add 'Ouvre un nouveau Fichier XL
    Sheets(1).Range("A1") = Cellule.Value
    'Instruction éventuelle pour formater Sheets(1).Range("A1")
    'On en fait quoi de ce nouveau fichier ? Pas d'enregistrement ? Pas de fermeture ? Ca risque de faire beaucoup, avec un fichier par cellule, selon la taille de la plage...
Next Cellule

End Sub

PS : Ce n'est pas Range(Cell), car Cell est déjà un objet Range...

Bonjour Pédro,

Ça fonctionne, sauf que ça me copie uniquement la valeur de la cellule.

Alors que je souhaite copier la plage nommée (toutes les plages nommées sont dans "SERVICES")

Sub AllColleEtSauve()

Dim AllServ As String, Cellule As Range, LaDate As String

For Each Cellule In Range("SERVICES")

LaDate = Format(Date, "YYYY-M-D")

Workbooks.Add 'Ouvre un nouveau Fichier XL

Sheets(1).Range("A1") = Cellule.Value

'Instruction éventuelle pour formater Sheets(1).Range("A1")

'On en fait quoi de ce nouveau fichier ? Pas d'enregistrement ? Pas de fermeture ? Ca risque de faire beaucoup, avec un fichier par cellule, selon la taille de la plage...

ActiveWorkbook.SaveAs Filename:= _

"C:\Users\" _

& Cellule.value & "-" & LaDate & ".xlsx", _

FileFormat:=xlNormal, Password:="", WriteResPassword:="", _

ReadOnlyRecommended:=False, CreateBackup:=False

Next Cellule

End Sub

J'ai ajouté l’enregistrement.

Merci de ton aide,

Des idées ?

saaku a écrit :

Des idées ?

Pour avoir des idées, il faudrait comprendre ce que vous voulez précisément faire...

Actuellement, vous êtes partis pour créer autant de fichier qu'il y a de cellules dans votre plage. Chacun de ces fichiers n'aurait qu'une seule cellule complétée.

C'est exactement que je souhaite. Si j'ai 10 cellules sur ma plage, j'aurais 10 fichiers.

Dans ces 10 cellules, il y a 10 noms de plages que je souhaite copier sur ces 10 nouveaux fichiers. (1fichier pour chaque noms de plages)

J'ai l'impression qu'il me manque juste un petit truc dans le code : sur excel ça serait INDIRECT

saaku a écrit :

C'est exactement que je souhaite. Si j'ai 10 cellules sur ma plage, j'aurais 10 fichiers.

Dans ces 10 cellules, il y a 10 noms de plages que je souhaite copier sur ces 10 nouveaux fichiers. (1fichier pour chaque noms de plages)

J'ai l'impression qu'il me manque juste un petit truc dans le code : sur excel ça serait INDIRECT

Je viens de comprendre cette histoire de noms de plage...

Un essai :

'Remplacer :
Sheets(1).Range("A1") = Cellule.Value
'Par :
ThisWorkbook.Sheets("Nom_A_Adapter").Range(Cellule.Value).Copy Sheets(1).Range("A1")

Super merci Pédro, ça fonctionne :

Dim AllServ As String, Cellule As Range, LaDate As String

For Each Cellule In Range("SERVICES")

LaDate = Format(Date, "YYYY-M-D")

ThisWorkbook.Sheets("Synthese").Range(Cellule.Value).Copy

Workbooks.Add 'Ouvre un nouveau Fichier XL

Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:= _

False, Transpose:=False

Selection.PasteSpecial 8

Next Cellule

End Sub