Microsoft 365 Aide pour code copier coller

clamatt

XLDnaute Nouveau
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 » A2:D36 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
 

Pièces jointes

  • FICHE NAVETTE - VIERGE - Copie.xlsm
    78.6 KB · Affichages: 17
Solution
Bonjour à toutes & à tous, bonjour @clamatt
protéger par mot de passe perso, cette fiche navette pour éviter toutes mauvaises manipulations d'autres personnes
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...

youky(BJ)

XLDnaute Barbatruc
>>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
 

Pièces jointes

  • FICHE NAVETTE - VIERGE - Copie.xlsm
    74.5 KB · Affichages: 3

AtTheOne

XLDnaute Impliqué
Supporter XLD
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
Voilà, voir la pièce jointe
A bientôt
 

Pièces jointes

  • FICHE NAVETTE - VIERGE -AtTheOne quater.xlsm
    72.7 KB · Affichages: 1

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonjour à toutes & à tous, bonjour @clamatt
protéger par mot de passe perso, cette fiche navette pour éviter toutes mauvaises manipulations d'autres personnes
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 :
1685182629266.png

Voir le fichier joint
A bientôt
 

Pièces jointes

  • FICHE NAVETTE - VIERGE -AtTheOne quinquies.xlsm
    73.1 KB · Affichages: 2
Dernière édition:

clamatt

XLDnaute Nouveau
Bonjour
Est ce que cet exemple irait pour toi ?
Bonjour herve62
Merci, c'est très bien en plus avec les bonnes proportions, mais est-il possible de sélectionner seulement mon tableau A2 : D36. de plus, il peut y avoir dans le mois plusieurs fiches avec (des dates et données variables) les une en dessous des autres et si possible encore de séparer chaque plage d'une ligne pour bien séparer les différentes fiches coller (pour la traçabilité). je ne sais pas si c'est réalisable.
 

clamatt

XLDnaute Nouveau
ok, merci je le fais tout de suite, en revanche quand tu dis " Le tableau par contre doit toujours avoir le même nombre de lignes." du coup il prend 2 feuilles et il doit etre aussi imprimé en papier et tenir que dans 1 feuille. merci
 
Dernière édition:

AtTheOne

XLDnaute Impliqué
Supporter XLD
Bonsoir à toutes & à tous, bonsoir @clamat
J'arrive un peu tard comme d'hab ...
Avec également les mois accentués

La macro :
VB:
'___________________________________________________________
'Recopier la fiche navette dans la feuille du mois prochain
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯

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(WorksheetFunction.EoMonth(Date, 1), "mmmm")) 'Mois Prochain
     Set Sh_C = ThisWorkbook.Worksheets(Mois)
  
     With Sh_C
          NbFiches = Round(.Cells(.Rows.Count, 1).End(xlUp).Row / NbL, 0) '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 Destination:=.Cells(NbFiches * NbL + 1, 1) 'Copie de la fiche entière
     End With
  
     Application.CutCopyMode = False
  
End Sub
Voir le fichier joint
EDIT : J'ai nommé le tableau "Tb_Navette"
 

Pièces jointes

  • FICHE NAVETTE - VIERGE -AtTheOne.xlsm
    72.8 KB · Affichages: 4

AtTheOne

XLDnaute Impliqué
Supporter XLD
Re, Re Bonsoir
Par contre j'aime bien l'idée de @youky(BJ) de ne pas multiplier les cases à cocher en faisant un pastespécial sans argument (car quand il y en a beaucoup, cela alourdit le fichier).
J'ai donc instrumenté tes 2 cases à cocher (renommées à cet effet CkB_OUI et CkB_NON) qui appelle la macro suivante en cas de clic sur l'une d'entre elles :
VB:
Sub CkB_OUI_NON_Cliquer()
          Nom = Application.Caller
        
          Set Rg = ActiveSheet.[D5]
          Texte = "Contient des chèques bancaires & CESU : "
        
          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

et j'ai modifié la macro de transfert de la Fiche Navette :
VB:
'___________________________________________________________
'Recopier la fiche navette dans la feuille du mois prochain
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯

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(WorksheetFunction.EoMonth(Date, 1), "mmmm")) 'Mois Prochain
     Set Sh_C = ThisWorkbook.Worksheets(Mois)
  
     With Sh_C
          NbFiches = Round(.Cells(.Rows.Count, 1).End(xlUp).Row / NbL, 0)  '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                        'Copie de la fiche entière sans les ChekBoxes
     End With
  
     Application.CutCopyMode = False
  
End Sub

Voir la pièce jointe
A bientôt
 

Pièces jointes

  • FICHE NAVETTE - VIERGE -AtTheOne bis.xlsm
    73.5 KB · Affichages: 4

clamatt

XLDnaute Nouveau
>>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
Bonsoir et merci youky
la date en D 3 ne me gênait pas, en revanche la fiche navette se colle dans la feuille de juin et non en mai (mois en cours) de plus, il manque le bas du tableau 8 lignes exactement), je te remercie pour ton aide précieuse et le temps que tu y passes.
 

Discussions similaires

Réponses
6
Affichages
362
Réponses
10
Affichages
390

Statistiques des forums

Discussions
311 725
Messages
2 081 949
Membres
101 851
dernier inscrit
vaiata