Copier coller formules

Le 13/10/2020 à 16:38

Bonjour,

J'ai un code ci dessous qui permet de copier une sélection dans une nouvelle feuille.

Je voudrais coller les formules pour les avoir dans la nouvelle feuille mais je n'y arrive pas

Voici le code qui ne colle que les valeurs :

'COLLER SELECTION
' Recherche dans 2021 la ligne correspondant à la date sasie
For Each cell In Range("d4:d380")
    If cell.Value = CDate(depart) Then ' si = à la date sasie
        debut = cell.Row ' lig = au numéro de ligne de la feuil1
        Exit For
    End If
Next cell
' Insérer date - 1 dans la nouvelle feuille en d3 pour permettre que les fonctions fonctionnent
Worksheets(mafeuille).Range("D3") = ActiveSheet.Range("d" & debut - 1)
'calcul de la derniere cellue à copier avec date de debut et ajouter le nb de semaine multiplier par nb de semaines
fin = debut + nb_sem * 7 - 1
fin1 = nb_sem * 7 + 4
ActiveSheet.Range(debut & ":" & fin).Copy Destination:=Worksheets(mafeuille).Range("4" & ":" & fin1)
Worksheets(mafeuille).Range("a4:a10") = ActiveSheet.Range("a" & debut).Value

et le code complet de la procédure :

Sub dupliquer()
'libérer applis pour accélerer la procédure
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False

'Déclaration variable
    Dim plageb As Range
    Dim mafeuille As String

' Déprotéger la feuille vide
Sheets("vide").Unprotect

' CREATION NOUVELLE FEUILLE : saisie du nom de la feuille à créer
retour_mafeuille:
Dim sh As Worksheet
retour_feuille:
mafeuille = InputBox("Nom de la feuille à créer") ' Présentation d'une zone de saisie pour demander le numéro de la facture à l'utilisateur
If IsDate(mafeuille) Then
    MsgBox "Vous devez saisir un nom de feuille mais pas une date"
    GoTo retour_feuille
End If
' Vérifier si la feuille existe
For Each sh In Worksheets
    If sh.Name = mafeuille Then
        MsgBox "cette feuille esiste deja"
        GoTo retour_mafeuille
    End If
Next
Sheets("Vide").Copy after:=Sheets(Sheets.Count) ' Faire une copie de la feuille vide à insérer après la dernière feuille
ActiveSheet.Range("a4:ch39").ClearContents ' Effacer les données de la nouvelle feuille de a4 à ch39
ActiveSheet.Name = mafeuille ' Renommer la feuille avec la valeur de la saisie mafeuille
Sheets("2021").Activate ' Activer la feuille 2021

' insérer la DATE DE DEPART et verifier si date est en 2021, si est un lundi, si est une date
retour_depart:
depart = InputBox("Saisir un lundi" & Chr(10) & " sous cette forme " & Chr(10) & " 12/03/2021 par exemple")
If Not IsDate(depart) Then
    MsgBox "La date n'est pas valideé"
    GoTo retour_depart
ElseIf CDate(depart) > "06/01/2022" Then
    MsgBox "La date doit être comprise entre le 28/12/2020 et le 06/01/2022"
    GoTo retour_depart
ElseIf CDate(depart) < "28/12/2020" Then
    MsgBox "La date doit être comprise entre le 28/12/2020 et le 06/01/2022"
    GoTo retour_depart
ElseIf Format(depart, "w", 2) <> 1 Then
    MsgBox "la date doit correspondre à un lundi"
    GoTo retour_depart
End If

' insérer le NB SEMAINE et verifier si valeur est égale ou 4 ou 5
retour_nb_sem:
nb_sem = InputBox("combien de semaines, 4 ou 5")
If (nb_sem < 4 Or nb_sem > 5) Then
    MsgBox "vous devez saisir 4 ou 5"
    GoTo retour_nb_sem
End If

'COLLER SELECTION
' Recherche dans 2021 la ligne correspondant à la date sasie
For Each cell In Range("d4:d380")
    If cell.Value = CDate(depart) Then ' si = à la date sasie
        debut = cell.Row ' lig = au numéro de ligne de la feuil1
        Exit For
    End If
Next cell
' Insérer date - 1 dans la nouvelle feuille en d3 pour permettre que les fonctions fonctionnent
Worksheets(mafeuille).Range("D3") = ActiveSheet.Range("d" & debut - 1)
'calcul de la derniere cellue à copier avec date de debut et ajouter le nb de semaine multiplier par nb de semaines
fin = debut + nb_sem * 7 - 1
fin1 = nb_sem * 7 + 4
ActiveSheet.Range(debut & ":" & fin).Copy Destination:=Worksheets(mafeuille).Range("4" & ":" & fin1)
Worksheets(mafeuille).Range("a4:a10") = ActiveSheet.Range("a" & debut).Value

'Activer feuille créée, Protéger feuille vide et retour sur la feuille créée
Worksheets(mafeuille).Activate
Application.CutCopyMode = False
Sheets("vide").Protect
ActiveSheet.Range("a1").Select

' Effacer le format en bas de feuille si que 4 semaines
If nb_sem = 4 Then
    ActiveSheet.Range("a32:ch39").Clear
End If

Unload UserMenuSal
UserMenuSal.Show 0

Application.ScreenUpdating = True
Application.DisplayStatusBar = True
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
End Sub
Le 13/10/2020 à 16:53

Bonjour sylvainpyc,

Avec VBA :

Règle N°1 : On utilise le copié/collé que dans de rares cas où il n'y a pas d'autres solution !

Règle N°2 : On utilise les .select que dans les rares cas où on en a besoin !

Cela permet d'alléger le code et de rendre les macros plus rapide et donc fluide.

Voici ton code, avec correction, je n'ai pas pu tester car pas de fichier :

    'COLLER SELECTION
' Recherche dans 2021 la ligne correspondant à la date sasie

Dim formule As Variant

For Each cell In Range("d4:d380")
    If cell.Value = CDate(depart) Then ' si = à la date sasie
        debut = cell.Row ' lig = au numéro de ligne de la feuil1
        Exit For
    End If
Next cell
' Insérer date - 1 dans la nouvelle feuille en d3 pour permettre que les fonctions fonctionnent
Worksheets(mafeuille).Range("D3") = ActiveSheet.Range("d" & debut - 1)
'calcul de la derniere cellue à copier avec date de debut et ajouter le nb de semaine multiplier par nb de semaines
fin = debut + nb_sem * 7 - 1
fin1 = nb_sem * 7 + 4
Worksheets(mafeuille).Range("a4:a10") = ActiveSheet.Range("a" & debut).Value

formule = ActiveSheet.Range(debut & ":" & fin).Formula
Worksheets(mafeuille).Range("4" & ":" & fin1) = formule

Cela fonctionne comme il faut ?

Bonne fin de journée,

Baboutz

Le 13/10/2020 à 17:04

Bonjour sylvainpyc, Salut Baboutz,

Baboutz, c'est toi qui m'as devancé cette fois . Je vais être moins conventionnel que toi et rester sur la même structure. Car j'ai l'impression que l'erreur vient de la variable fin1 :

fin1 = nb_sem * 7 + 3 'equivaut à 4 + nb_sem * 7 - 1
Worksheets(mafeuille).Range("a4:a10") = ActiveSheet.Range("a" & debut).Value
ActiveSheet.Range(debut & ":" & fin).Copy
Worksheets(mafeuille).Range("4" & ":" & fin1).PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

En effet, sylvainpyc, la dimension de collage semble différente à la dimension de la plage copiée. En mettant -1, je pense que ça devrait aller.

Cdlt,

Le 13/10/2020 à 17:11

Ah ! En effet si la longueur de la plage n'est pas la même ça risque de poser une problème dans mon code aussi, je n'ai pas checké ça

Le 13/10/2020 à 18:25

merci

en fait mon code fonctionnait, il collait bien mes formules de la feuille 2021 à ma nouvelle feuille (feuille mensuelle)

mais depuis ma nouvelle feuille, j'ai un bouton qui me permet de refaire la même chose dans le sens inverse et c'est la que ca bug (mettre à jour 2021 avec les modifs de la feuille mensuelle)

Donc c'est lors de ces retours que je n'avais plus les formules dans ma feuille 2021 donc forcément je e pouvais pas coller les formules qui n'éxistaient plus.

Voici mon code de la feuille créée :

Private Sub CB1_Click() 'Mettre à jour 2021 => copier les horaires de la feuille dans 2021
Dim DerCol As Integer, col As Integer
Dim c
Dim DernLigne As Long
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False

    With ActiveSheet 'Ligne de départ et de fin à coller
        DernLigne = Range("D" & Rows.Count).End(xlUp).Row
        depart = .Cells(4, 4).Value
        fin = DernLigne
    End With
            ' recherche dans 2021 la ligne correspondant à la date de début
            Set Plage = ThisWorkbook.Worksheets("2021").Range("d4:d380")
            For Each cell In Plage
                If cell.Value = depart Then
                    debut = cell.Row ' debut = numéro de ligne de 2021
                End If
            Next cell

Set range_to_copy = ActiveSheet.Range("D" & "4" & ":" & "CH" & fin)
Set range_for_pasting = Worksheets("2021").Range("D" & debut)
range_to_copy.Copy
range_for_pasting.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
range_for_pasting.PasteSpecial 8

Worksheets("2021").Activate 'Se positionner sur 2021

Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
End Sub

le pb se situe ici

Dsl de m'être trompé dans mes explications

Le 13/10/2020 à 18:47

Et bien, au temps pour moi, je ne sais pas pourquoi, j'étais persuadé qu'il fallait que la plage de collage soit de même dimension que la plage de copie...

Le 13/10/2020 à 18:57

J'ai réglé le pb comme cela

Private Sub CB1_Click() 'Mettre à jour 2021 => copier les horaires de la feuille dans 2021
Dim DerCol As Integer, col As Integer
Dim c
Dim DernLigne As Long
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
ActiveSheet.DisplayPageBreaks = False
Application.EnableEvents = False

    With ActiveSheet 'Ligne de départ et de fin à coller
        DernLigne = Range("D" & Rows.Count).End(xlUp).Row
        depart = .Cells(4, 4).Value
        fin = DernLigne
    End With
            ' recherche dans 2021 la ligne correspondant à la date de début
            Set Plage = ThisWorkbook.Worksheets("2021").Range("d4:d380")
            For Each cell In Plage
                If cell.Value = depart Then
                    debut = cell.Row ' debut = numéro de ligne de 2021
                End If
            Next cell
ActiveSheet.Range("D" & "4" & ":" & "CH" & fin).Copy Destination:=Worksheets("2021").Range("D" & debut)

Worksheets("2021").Activate 'Se positionner sur 2021

Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
ActiveSheet.DisplayPageBreaks = True
Application.EnableEvents = True
End Sub

Merci de votre aide

Cordialement

Rechercher des sujets similaires à "copier coller formules"