Répéter des valeurs de cellule en fonction de sa feuille précédente en VBA
Bonjour à tous,
Dans un classeur Excel j'ai un onglet liste, un onglet Modèle. De la j'ai une macro qui me permet de créer toutes mes fiches avec les couleurs correspondantes.
Seulement il me manque encore une macro qui prendra la valeur des cellules de la feuille 1234 J vers la feuille 1234 N/W et de la feuille 4321 j vers la feuille 4321 N/W
Je peux faire un copier coller des cellules (D9:D12;D14:D22;B24:D31;I24:I31;L14:L22;L24:L31) de la feuille J vers la feuille N/W seulement j'ai plus de 200 feuilles..
Merci de votre aide,
Cordialement
Will
Bonjour,
Pour copier à chaque fois les mêmes cellules de la feuille XXX J dans les mêmes cellules de la feuille correspondante XXX N/W, l'idée serait de faire ça :
sub test()
dim ws as worksheet
dim nomdest$
for each ws in worksheets 'pour chaque feuille
if ws.name like "*J" then 'si nom feuille termine par J
nomdest = replace(ws.name, "J", "N/W") 'nom feuille destination = nom ws avec J remplacé par N/W
ws.range(...).copy 'copier range précisée de feuille ws (J)
sheets(nomdest).range(...).paste 'coller sur range précisée de feuille N/W correspondante
end if
next ws
end subCdlt,
Bonjour 3GB,
Je te remercie de ton retour!
Alors j'ai ingérer le module mais ca ne fonctionne pas ..
Tu aurais une solution?
Mes valeurs des feuilles "J" ne se répètent pas sur la "N/W"
Dim ws As Worksheet
Dim nomdest$
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
nomdest = Replace(ws.Name, "J", "N/W") 'nom feuille destination = nom ws avec J remplacé par N/W
ws.Range ("D9:D12;D14:D22;B24:D31;I24:I31;L14:L22;L24:L31")
.Copy 'copier range précisée de feuille ws (J)
Sheets(nomdest).Range("D9:D12;D14:D22;B24:D31;I24:I31;L14:L22;L24:L31").Paste 'coller sur range précisée de feuille N/W correspondante
End If
Next ws
End SubAlors, un essai, si seules les valeurs sont à copier :
Sub test()
Dim ws As Worksheet
Dim nomdest$
dim adresses$
adresses = "D9:D12;D14:D22;B24:D31;I24:I31;L14:L22;L24:L31" 'c'est pour la longueur de la ligne :)
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
nomdest = Replace(ws.Name, "J", "N/W") 'nom feuille destination = nom ws avec J remplacé par N/W
Sheets(nomdest).Range(adresses).value = ws.Range(adresses).value 'N/W prend valeurs J
End If
Next ws
End SubSinon :
Sub test()
Dim ws As Worksheet
Dim nomdest$
dim adresses$
adresses = "D9:D12;D14:D22;B24:D31;I24:I31;L14:L22;L24:L31" 'c'est pour la longueur de la ligne :)
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
nomdest = Replace(ws.Name, "J", "N/W") 'nom feuille destination = nom ws avec J remplacé par N/W
ws.Range(adresses).copy destination:=Sheets(nomdest).Range(adresses)'N/W prend valeurs J
End If
Next ws
End SubCdlt,
Je pense qu'on y est presque !!
J'ai modifié N/W par NW car sur la feuille de destination il n’apparaît pas mais ça bloque ici:
ws.Range(adresses).Copy Destination:=Sheets(nomdest).Range(adresses) 'NW prend valeurs JSub testvaleur()
Dim ws As Worksheet
Dim nomdest$
Dim adresses$
adresses = "D9:D12;D14:D22;B24:D31;I24:I31;L14:L22;L24:L31" 'c'est pour la longueur de la ligne :)
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
nomdest = Replace(ws.Name, "J", "NW") 'nom feuille destination = nom ws avec J remplacé par NW
ws.Range(adresses).Copy Destination:=Sheets(nomdest).Range(adresses) 'NW prend valeurs J
End If
Next ws
End SubCdt,
Et si on faisait un mix avec cela?
Cela pourrais vous aider?
Sub test()
Dim x
Dim adresses$
adresses = "D9:D12;D14:D22;B24:D31;I24:I31;L14:L22;L24:L31"
For Each x In ThisWorkbook.Worksheets
If LCase(Right(x.Name, 1)) = "NW" Then
x.Tab.Color = RGB(255, 0, 0)
x.Range(adresses) = ThisWorkbook.Worksheets(Left(x.Name, Len(x.Name) - 1) & "J").Range(adresses).Value
ElseIf LCase(Right(x.Name, 1)) = "J" Then
x.Tab.Color = RGB(0, 255, 0)
End If
Next x
End SubOui, c'est la discontinuité qui bloque...
Comme ça, ça devrait être mieux :
Sub testvaleur()
Dim ws As Worksheet
Dim nomdest$
Dim adresses
dim i%
adresses = Array("D9:D12", "D14:D22", "B24:D31", "I24:I31", "L14:L22", "L24:L31")
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
nomdest = Replace(ws.Name, "J", "NW") 'nom feuille destination = nom ws avec J remplacé par NW
for i = 0 to ubound(adresses)
ws.Range(adresses(i)).Copy Destination:=Sheets(nomdest).Range(adresses(i)) 'NW prend valeurs J
next i
End If
Next ws
End SubCdlt,
Non, ça ne changera rien, les instructions ne sont pas les mêmes, c'est vraiment le fait de coller sur un ensemble de zones discontinues qui pose problème...
Mais on peut rajouter les instructions :
Sub testvaleur()
Dim ws As Worksheet
Dim nomdest$
Dim adresses
dim i%
adresses = Array("D9:D12", "D14:D22", "B24:D31", "I24:I31", "L14:L22", "L24:L31")
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
ws.tab.color = RGB(0, 255, 0)
nomdest = Replace(ws.Name, "J", "NW") 'nom feuille destination = nom ws avec J remplacé par NW
for i = 0 to ubound(adresses)
ws.Range(adresses(i)).Copy Destination:=Sheets(nomdest).Range(adresses(i)) 'NW prend valeurs J
next i
End If
if ws.name Like "*NW" then
ws.tab.color = RGB(255,0,0)
end if
Next ws
End SubAIe aie aie ....
Ça fonctionne quand je mets des valeurs ! seulement à la fin cela me met "erreur indice "9"
et erreur toujours sur la même ligne..
Ça fonctionne ? Pour une partie des feuilles seulement ?
Il faut bien que les feuilles soient en couple XXX J et XXX NW, YYY J et YYY NW. Au moindre N/W, Nw, ça ne marche plus. Si on a 1234J et 1234 NW, ou bien 12 34 J et 1234 NW, ça plante. C'est un problème de feuille en tout cas...
Et si vraiment tu ne trouves pas, éventuellement, tu pourrais regarder les protections mais j'en doute.
Et bien cela fonctionne mais une fois qu'il a exécuté la Macro il se met en erreur et pourtant les feuilles sont bien nommée.. regardez par vous même :)
J'ai mis un bouton avec la macro :)
Je le modifie vous allez me dire ce que vous en pensez
Maintenant je n'arrive plus a faire fonctionner ma 1ere macro...
Sur le fichier, les feuilles sont absentes
Le code est censé copier les plages spécifiées de chaque feuille au suffixe J pour les coller dans une feuille au préfixe équivalent mais au suffixe NW.
Les erreurs portent donc essentiellement sur la feuille "PREFIXE NW" dont l'existence est fondamentale mais pas gérée dans le code en l'état...
Dès lors qu'une feuille PREFIXE J ne rencontre pas son homologue PREFIXE NW, PAF
On pourrait rajouter un contrôle de la feuille NW et je pense qu'il n'y aurait plus d'erreur...
Sub testvaleur()
Dim ws As Worksheet
Dim nomdest$
Dim adresses
dim i%
adresses = Array("D9:D12", "D14:D22", "B24:D31", "I24:I31", "L14:L22", "L24:L31")
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
ws.tab.color = RGB(0, 255, 0)
nomdest = Replace(ws.Name, "J", "NW") 'nom feuille destination = nom ws avec J remplacé par NW
for i = 0 to ubound(adresses)
if FeuilleExiste(nomdest) then 'si la feuille de destination existe
ws.Range(adresses(i)).Copy Destination:=Sheets(nomdest).Range(adresses(i)) 'NW prend valeurs J
end if
next i
End If
if ws.name Like "*NW" then
ws.tab.color = RGB(255,0,0)
end if
Next ws
End Sub
Function FeuilleExiste(nomfeuille as string) as boolean
dim ws as worksheet
for each ws in worksheets
if ws.name = nomfeuille then
FeuilleExiste = true
exit function
end if
next ws
end functionOui désolé ma macro de base ne fonctionne plus
C'était ca mais ca beuge à feuille existe...:
Option Explicit
Sub Ajouter_Feuilles()
'Sub Ajouter_Feuilles()
Dim J As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
For J = 1 To ws.Range("A" & Rows.Count).End(xlUp).Row
If Not FeuilleExiste(ws.Range("A" & J).Value) Then
Sheets("Modèle").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = ws.Range("A" & J)
Range("E3") = ActiveSheet.Name ' Met le nom de la feuille dans la cellule D3
End If
Next J
ws.Select
'End Sub
'Sub Couleuronglet()
'
Dim feuille As Variant
For feuille = 1 To Sheets.Count
If Sheets(feuille).Range("E4") = "FORFAIT" Then
Sheets(feuille).Tab.ColorIndex = 44
Else
If Sheets(feuille).Range("E4") = "JOUR" Then
Sheets(feuille).Tab.ColorIndex = 43
Else
If Sheets(feuille).Range("E4") = "NUIT / WEEK-END" Then
Sheets(feuille).Tab.ColorIndex = 3
Else
If Sheets(feuille).Range("E4") = "Modèle" Then
Sheets(feuille).Tab.ColorIndex = 5
Else
If Sheets(feuille).Range("E4") = "LA JOURNEE" Then
Sheets(feuille).Tab.ColorIndex = 43
Else
End If
End If
End If
End If
End If
Next
'End Sub
Sub testvaleur()
Dim ws As Worksheet
Dim nomdest$
Dim adresses
Dim i%
adresses = Array("D9:D12", "D14:D22", "B24:D31", "I24:I31", "L14:L22", "L24:L31")
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
ws.Tab.Color = RGB(0, 255, 0)
nomdest = Replace(ws.Name, "J", "NW") 'nom feuille destination = nom ws avec J remplacé par NW
For i = 0 To UBound(adresses)
If FeuilleExiste(nomdest) Then 'si la feuille de destination existe
ws.Range(adresses(i)).Copy Destination:=Sheets(nomdest).Range(adresses(i)) 'NW prend valeurs J
End If
Next i
End If
If ws.Name Like "*NW" Then
ws.Tab.Color = RGB(255, 0, 0)
End If
Next ws
Function FeuilleExiste(nomfeuille As String) As Boolean
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = nomfeuille Then
FeuilleExiste = True
Exit Function
End If
Next ws
End Function
End SubJe vais rééessyaer une fois que j'ai réussi à remeettre celle ci en route et je reviens vers vous pour vous dire si cela fonctionne.
Je pense qu'on tiens le bon fil!
C'est marrant, je travaille sur un fichier avec exactement mais exactement le même code que AjouterFeuilles, grosse dédicace à Sandra
Ici, la fonction est indépendante de la procédure. Elle est appelée lors de l'exécution cependant.
Option Explicit
Sub Ajouter_Feuilles()
Dim J As Long
Dim ws As Worksheet
with Sheets("???") '<<< adapter (j'ai restructuré le fichier de base)
For J = 1 To .Range("A" & .Rows.Count).End(xlUp).Row 'pour chaque cellule de la liste
If Not FeuilleExiste(.Range("A" & J).Value) Then 'si le nom de feuille n'existe pas
Sheets("Modèle").Copy after:=Sheets(Sheets.Count) 'copie modele en dernier
with Sheets(Sheets.count) 'avec la dernière feuille (ou activesheet)
.Name = .Range("A" & J) 'nom = AJ de feuille liste
.Range("E3") = .Range("A" & J) 'E3 = AJ de feuille liste
end with
End If
Next J
end with
End sub
'<<<<<MACRO INADAPTÉE OU INUTILE A TERME CAR ONGLETS FIXES APPAREMMENT
'----------------------------------------
Sub Couleuronglet()
'
Dim ws as worksheet
Dim typ as string
For each ws in worksheets 'pour chaque feuille
typ = ws.range("E4").value 'typ = valeur en E4
select case typ 'sélectionner selon valeur de typ
case "FORFAIT": ws.Tab.ColorIndex = 44 'forfait, couleur orange
case "JOUR", "LA JOURNEE": ws.Tab.ColorIndex = 43 'etc
case "NUIT / WEEK-END": ws.Tab.ColorIndex = 3
case "Modèle": ws.Tab.ColorIndex = 5
end select
Next
End Sub
'-----------------------------------------
Sub testvaleur()
Dim ws As Worksheet
Dim nomdest$
Dim adresses
Dim i%
adresses = Array("D9:D12", "D14:D22", "B24:D31", "I24:I31", "L14:L22", "L24:L31")
For Each ws In Worksheets 'pour chaque feuille
If ws.Name Like "*J" Then 'si nom feuille termine par J
ws.Tab.Color = RGB(0, 255, 0)
nomdest = Replace(ws.Name, "J", "NW") 'nom feuille destination = nom ws avec J remplacé par NW
For i = 0 To UBound(adresses)
If FeuilleExiste(nomdest) Then 'si la feuille de destination existe
ws.Range(adresses(i)).Copy Destination:=Sheets(nomdest).Range(adresses(i)) 'NW prend valeurs J
End If
Next i
End If
If ws.Name Like "*NW" Then
ws.Tab.Color = RGB(255, 0, 0)
End If
Next ws
end sub
Function FeuilleExiste(nomfeuille As String) As Boolean
Dim ws As Worksheet
For Each ws In Worksheets
If ws.Name = nomfeuille Then
FeuilleExiste = True
Exit Function
End If
Next ws
End FunctionVoici les codes réorganisés. Il faut saisir le nom de feuille dans la 1è macro, supprimer selon moi la 2è inutile. Maintenant, la 3è devrait marcher...
Edit : A noter que tu avais une fonction FeuilleExiste avant la mienne. Donc il faudra surveiller qu'il n'y ait pas 2 fonctions du même nom qui cohabitent et le cas échéant en supprimer une.
Ah c'est peut être le même au début je piochait dans tout ce que je trouvait pour arriver à ajouter des feuilles
Alors merci de ton dévouement mais du coup je comprend plus rien
Alors surprise!!! j'ai pas compris j'ai un mixe mais ça fonctionne!!
Alors Attendez je vais uniformiser tout cela car j'ai plus qu'un soucis de couleur d'onglet .. J'aimerai avoir ceux que je dois supprimés.. (c'est moi qui l'avait fait)
Vous êtes un génie!!
Et bien, je le vois pas ici le 2è mais je dirais le 2è...
lors surprise!!! j'ai pas compris j'ai un mixe mais ça fonctionne!!
Alors Attendez je vais uniformiser tout cela car j'ai plus qu'un soucis de couleur d'onglet .. J'aimerai avoir ceux que je dois supprimés.. (c'est moi qui l'avait fait)
Vous êtes un génie!!
A l'occasion, j'ai un autre Poste qui aurai surement besoin de votre aide c'est encore plus complexe...
J'ai pas compris ce qui s'est passé mais merci ! je ne refuse jamais qu'on me qualifie de génie
Quel problème de couleur ?
Quel poste ? Celui resté sans réponse ?