Vous utilisez un navigateur obsolète. Il se peut que ce site ou d'autres sites Web ne s'affichent pas correctement. Vous devez le mettre à jour ou utiliser un navigateur alternatif.
Bonsoir a tous,
Par suite de méconnaissance dans le monde du code VBA, je vous sollicite pour créer un bouton VBA pour copier le tableau « FICHE NAVETTE » A236 et de le coller dans une des feuilles suivant le mois en cours. Plusieurs « FICHES NAVETTES » peuvent être misent les unes en dessous des autres séparées d’une ligne en chaque copie. Est-ce possible ?
Un exemple de ce que je veux dans la feuille "EXEMPLE"
merci pour votre aide
Voilà, avec le mot de passe enregistré dans la constante MdP ("MonMotDePasse" à changer par le tien !)
Enrichi (BBcode):
'———————————————————————————————————————————————————————————
'Recopier la fiche navette dans la feuille du mois courant
'———————————————————————————————————————————————————————————
Const MdP$ = "MonMotDePasse"
Sub TransférerNavette()
Dim Sh_S As Worksheet, Sh_C As Worksheet, NbL As Integer, Mois$, NbFiches As Integer
Set Sh_S = ThisWorkbook.Worksheets("FICHE NAVETTE")
NbL = Sh_S.[tb_Navette].Rows.Count + 1 'Nombre de...
>>Suivant le mois en cours
Donc rectif
Voici un nouveau fichier qui copie sur l'onglet suivant la date et non pas la date en D3
Le nombre de lignes peut être modifié qu'importe.
Bruno
Bonjour youky,
je reviens vers toi, car j'ai modifier mon tableau que tu m'avais très bien géré.
j'ai rajouté une colonne en début de tableau, évidemment cela à décalé le tableau + les formules ect...
Du coup la formule " contient chèques bancaires & CESU" ne fonctionne plus après le transfère et aussi et surtout la fiche navette ne se transfère plus les unes en dessous des autres, comme pour la dernière trame. en revanche ça se transfère dans le mois en cours.
je suis désolé, c'est la dernière modification pour cette feuille.
merci beaucoup si tu peux me régler ces problèmes.
Bonjour à toutes & à tous, bonjour @clamatt
Tu t'adresses à youky, mais c'est ma dernière proposition que tu présentes
Bon j'ai modifié mon code pour s'adapter à l'évolution de ton tableau.
La macro des cases à cocher OUI/NON recherche le texte "Contient des chèques bancaires & CESU : " pour ne plus être gêner par un changement de position de cette cellule.
VB:
Sub CkB_OUI_NON_Cliquer()
Nom = Application.Caller
texte = "Contient des chèques bancaires & CESU : "
On Error Resume Next
Set Rg = ActiveSheet.UsedRange.Find(What:="Contient des chèques bancaires & CESU : ", After:=ActiveSheet.Cells(1))
On Error GoTo 0
If Rg Is Nothing Then
MsgBox "Le texte ""Contient des chèques bancaires & CESU : """ & Chr(10) & "n'a pas été trouvé !"
Exit Sub
End If
Etat = ActiveSheet.Shapes(Nom).ControlFormat.Value
Select Case Nom
Case "CkB_OUI"
If Etat = xlOn Then
Rg.Value = texte & "OUI"
ActiveSheet.Shapes("CkB_NON").ControlFormat.Value = xlOff
Else
Rg.Value = texte & "NON"
ActiveSheet.Shapes("CkB_NON").ControlFormat.Value = xlOn
End If
Case "CkB_NON"
If Etat = xlOn Then
Rg.Value = texte & "NON"
ActiveSheet.Shapes("CkB_OUI").ControlFormat.Value = xlOff
Else
Rg.Value = texte & "OUI"
ActiveSheet.Shapes("CkB_OUI").ControlFormat.Value = xlOn
End If
End Select
End Sub
Le comptage des fiches navettes dans la feuille du mois cible se fait par un comptage du nombre d’occurrences du texte "Documents préparés par " et les données sont copiées en valeur (pour éviter les mises à jour automatiques des formules (par ex de la fonction AUJOURDHUI()) .
VB:
Sub TransférerNavette() Dim Sh_S As Worksheet, Sh_C As Worksheet, NbL As Integer, Mois$, NbFiches As Integer
Set Sh_S = ThisWorkbook.Worksheets("FICHE NAVETTE")
NbL = Sh_S.[tb_Navette].Rows.Count + 1 'Nombre de ligne de la Fiche +1 ligne intercalaire
Mois = UCase(Format(Date, "mmmm")) 'Mois en cours
Set Sh_C = ThisWorkbook.Worksheets(Mois)
With Sh_C
NbFiches = WorksheetFunction.CountIf(.UsedRange, "Documents préparés par ") 'Nombre de fiches déjà présentes pour ce Mois
Sh_S.[tb_Navette].EntireRow.Copy
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteFormats 'Pour recopier la hauteur des lignes
Sh_S.[tb_Navette].Copy
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteValues 'Copie de la fiche entière sans les ChekBoxes
End With
Application.CutCopyMode = False
End Sub
Bonjour à toutes & à tous, bonjour @clamatt
Tu t'adresses à youky, mais c'est ma dernière proposition que tu présentes
Bon j'ai modifié mon code pour s'adapter à l'évolution de ton tableau.
La macro des cases à cocher OUI/NON recherche le texte "Contient des chèques bancaires & CESU : " pour ne plus être gêner par un changement de position de cette cellule.
VB:
Sub CkB_OUI_NON_Cliquer()
Nom = Application.Caller
texte = "Contient des chèques bancaires & CESU : "
On Error Resume Next
Set Rg = ActiveSheet.UsedRange.Find(What:="Contient des chèques bancaires & CESU : ", After:=ActiveSheet.Cells(1))
On Error GoTo 0
If Rg Is Nothing Then
MsgBox "Le texte ""Contient des chèques bancaires & CESU : """ & Chr(10) & "n'a pas été trouvé !"
Exit Sub
End If
Etat = ActiveSheet.Shapes(Nom).ControlFormat.Value
Select Case Nom
Case "CkB_OUI"
If Etat = xlOn Then
Rg.Value = texte & "OUI"
ActiveSheet.Shapes("CkB_NON").ControlFormat.Value = xlOff
Else
Rg.Value = texte & "NON"
ActiveSheet.Shapes("CkB_NON").ControlFormat.Value = xlOn
End If
Case "CkB_NON"
If Etat = xlOn Then
Rg.Value = texte & "NON"
ActiveSheet.Shapes("CkB_OUI").ControlFormat.Value = xlOff
Else
Rg.Value = texte & "OUI"
ActiveSheet.Shapes("CkB_OUI").ControlFormat.Value = xlOn
End If
End Select
End Sub
Le comptage des fiches navettes dans la feuille du mois cible se fait par un comptage du nombre d’occurrences du texte "Documents préparés par " et les données sont copiées en valeur (pour éviter les mises à jour automatiques des formules (par ex de la fonction AUJOURDHUI()) .
VB:
Sub TransférerNavette() Dim Sh_S As Worksheet, Sh_C As Worksheet, NbL As Integer, Mois$, NbFiches As Integer
Set Sh_S = ThisWorkbook.Worksheets("FICHE NAVETTE")
NbL = Sh_S.[tb_Navette].Rows.Count + 1 'Nombre de ligne de la Fiche +1 ligne intercalaire
Mois = UCase(Format(Date, "mmmm")) 'Mois en cours
Set Sh_C = ThisWorkbook.Worksheets(Mois)
With Sh_C
NbFiches = WorksheetFunction.CountIf(.UsedRange, "Documents préparés par ") 'Nombre de fiches déjà présentes pour ce Mois
Sh_S.[tb_Navette].EntireRow.Copy
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteFormats 'Pour recopier la hauteur des lignes
Sh_S.[tb_Navette].Copy
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteValues 'Copie de la fiche entière sans les ChekBoxes
End With
Application.CutCopyMode = False
End Sub
Bonjour AtTheOne,
désolé pour la confusion du message et son destinataire, en effet, je viens de regardé le fil de la discussion.
merci pour tout, c'est parfait et merci pour l'explicatif de ton code, j'ai une dernière requête et omis de le préciser dans mon message précèdent, c'est de protéger par mot de passe perso, cette fiche navette pour éviter toutes mauvaises manipulations d'autres personnes peux-tu y remédier, merci AtTheOne.
bonne journée
Voilà, avec le mot de passe enregistré dans la constante MdP ("MonMotDePasse" à changer par le tien !)
Enrichi (BBcode):
'———————————————————————————————————————————————————————————
'Recopier la fiche navette dans la feuille du mois courant
'———————————————————————————————————————————————————————————
Const MdP$ = "MonMotDePasse"
Sub TransférerNavette()
Dim Sh_S As Worksheet, Sh_C As Worksheet, NbL As Integer, Mois$, NbFiches As Integer
Set Sh_S = ThisWorkbook.Worksheets("FICHE NAVETTE")
NbL = Sh_S.[tb_Navette].Rows.Count + 1 'Nombre de ligne de la Fiche +1 ligne intercalaire
Mois = UCase(Format(Date, "mmmm")) 'Mois en cours
Set Sh_C = ThisWorkbook.Worksheets(Mois)
With Sh_C
NbFiches = WorksheetFunction.CountIf(.UsedRange, "Documents préparés par ") 'Nombre de fiches déjà présentes pour ce Mois
Sh_S.[tb_Navette].EntireRow.Copy
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteFormats 'Pour recopier la hauteur des lignes
Sh_S.[tb_Navette].Copy
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteValues 'Copie de la fiche entière sans les ChekBoxes
End With
Application.CutCopyMode = False
End Sub
Sub CkB_OUI_NON_Cliquer()
Nom = Application.Caller
Dim Wsh As Worksheet
Set Wsh = ActiveSheet
texte = "Contient des chèques bancaires & CESU : "
On Error Resume Next
Set Rg = Wsh.UsedRange.Find(What:="Contient des chèques bancaires & CESU : ", After:=ActiveSheet.Cells(1))
On Error GoTo 0
If Rg Is Nothing Then
MsgBox "Le texte ""Contient des chèques bancaires & CESU : """ & Chr(10) & "n'a pas été trouvé !"
Exit Sub
End If
Etat = Wsh.Shapes(Nom).ControlFormat.Value
Wsh.Unprotect MdP
Select Case Nom
Case "CkB_OUI"
If Etat = xlOn Then
Rg.Value = texte & "OUI"
Wsh.Shapes("CkB_NON").ControlFormat.Value = xlOff
Else
Rg.Value = texte & "NON"
Wsh.Shapes("CkB_NON").ControlFormat.Value = xlOn
End If
Case "CkB_NON"
If Etat = xlOn Then
Rg.Value = texte & "NON"
Wsh.Shapes("CkB_OUI").ControlFormat.Value = xlOff
Else
Rg.Value = texte & "OUI"
Wsh.Shapes("CkB_OUI").ControlFormat.Value = xlOn
End If
End Select
Wsh.Protect MdP
End Sub
Remarque, il suffit d'aller dans le code VBA pour lire le mot de passe, si tu veux de protéger un peu plus, il faut aussi protéger le projet VBA par un mot de passe et masquer le projet :
Voilà, avec le mot de passe enregistré dans la constante MdP ("MonMotDePasse" à changer par le tiens !)
Enrichi (BBcode):
'———————————————————————————————————————————————————————————
'Recopier la fiche navette dans la feuille du mois courant
'———————————————————————————————————————————————————————————
Const MdP$ = "MonMotDePasse"
Sub TransférerNavette()
Dim Sh_S As Worksheet, Sh_C As Worksheet, NbL As Integer, Mois$, NbFiches As Integer
Set Sh_S = ThisWorkbook.Worksheets("FICHE NAVETTE")
NbL = Sh_S.[tb_Navette].Rows.Count + 1 'Nombre de ligne de la Fiche +1 ligne intercalaire
Mois = UCase(Format(Date, "mmmm")) 'Mois en cours
Set Sh_C = ThisWorkbook.Worksheets(Mois)
With Sh_C
NbFiches = WorksheetFunction.CountIf(.UsedRange, "Documents préparés par ") 'Nombre de fiches déjà présentes pour ce Mois
Sh_S.[tb_Navette].EntireRow.Copy
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteFormats 'Pour recopier la hauteur des lignes
Sh_S.[tb_Navette].Copy
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(NbFiches * NbL + 1, 1).PasteSpecial Paste:=xlPasteValues 'Copie de la fiche entière sans les ChekBoxes
End With
Application.CutCopyMode = False
End Sub
Sub CkB_OUI_NON_Cliquer()
Nom = Application.Caller
Dim Wsh As Worksheet
Set Wsh = ActiveSheet
texte = "Contient des chèques bancaires & CESU : "
On Error Resume Next
Set Rg = Wsh.UsedRange.Find(What:="Contient des chèques bancaires & CESU : ", After:=ActiveSheet.Cells(1))
On Error GoTo 0
If Rg Is Nothing Then
MsgBox "Le texte ""Contient des chèques bancaires & CESU : """ & Chr(10) & "n'a pas été trouvé !"
Exit Sub
End If
Etat = Wsh.Shapes(Nom).ControlFormat.Value
Wsh.Unprotect MdP
Select Case Nom
Case "CkB_OUI"
If Etat = xlOn Then
Rg.Value = texte & "OUI"
Wsh.Shapes("CkB_NON").ControlFormat.Value = xlOff
Else
Rg.Value = texte & "NON"
Wsh.Shapes("CkB_NON").ControlFormat.Value = xlOn
End If
Case "CkB_NON"
If Etat = xlOn Then
Rg.Value = texte & "NON"
Wsh.Shapes("CkB_OUI").ControlFormat.Value = xlOff
Else
Rg.Value = texte & "OUI"
Wsh.Shapes("CkB_OUI").ControlFormat.Value = xlOn
End If
End Select
Wsh.Protect MdP
End Sub
Remarque, il suffit d'aller dans le code VBA pour lire le mot de passe, si tu veux de protéger un peu plus, il faut aussi protéger le projet VBA par un mot de passe et masquer le projet : Regarde la pièce jointe 1170991
Voir le fichier joint
A bientôt
Merci AtTheOne,
j'ai fait comme dit ci-dessus (d'ailleurs très bien expliqué) donc, j'ai changé mon MDP, protégé ma feuille et quand je clic sur "oui ou non" j'ai une erreur avec une fenêtre tu verras en PJ. merci
AtTheOne,
oui, en effet, je ne t'ai pas bien lu, MDP modifier et tout est parfait, mille mercis à toi pour ton aide, je marque comme résolu.
bonne journée
Bonjour @clamatt
Plutôt que de passer par la messagerie personnel, reviens sur ce fil en y plaçant ton fichier avec uniquement la fiche navette vierge, les mois vierges et la correction que je t'ai suggérée en MP afin que je comprenne ce qui cloche. Les autres en profiteront c'est quand même le principe de ce site.
A tout de suite
re
Tu as commis une faute de frappe :
ta saisie : "Contient des chèques bancaires & CESU:* " (sans espace entre U et : et avec espace final !)
ce qu'il faut saisir "Contient des chèques bancaires & CESU : *" (avec espace entre U et : avec astérisque final)
à bientôt
Ce site utilise des cookies pour personnaliser le contenu, adapter votre expérience et vous garder connecté si vous vous enregistrez.
En continuant à utiliser ce site, vous consentez à notre utilisation de cookies.
36 et de le coller dans une des feuilles suivant le mois en cours. Plusieurs « FICHES NAVETTES » peuvent être misent les unes en dessous des autres séparées d’une ligne en chaque copie. Est-ce possible ?
