Copier sans mise en forme

Le 10/09/2020 à 16:06

Bonjour,

J'ai un code ci dessous qui me permet de coller des cellules d'une feuille à une autre et qui fonctionne bien

Mais à chaque copie la mise en forme conditionnelle se recopie et donc s'ajoute à la liste des mises en forme conditionnelle de la feuille de destination soit la feuille "2021"

Je voudrais si possible que cette mise en forme conditionnelle ne se recopie pas à chaque fois en sachant que ces mises en forme conditionnelles sont en place dans la feuille "2021"

Le code qui bug est dans le code en bas de page

Code Complet :

Private Sub Trame1_Click()
Dim wrsSource As Worksheet
Dim wrsTarget As Worksheet
Set wrsSource = Worksheets("Trame de base")
Set wrsTarget = Worksheets("2021")
Dim CduDate As String
Dim MyDate As Date
     Application.CutCopyMode = False

CduDate = Date1.Value
If IsDate(CduDate) = True Then
MyDate = Format(CduDate, "dd/mm/yyyy")
Else
MsgBox "Entrer une date valide"
Exit Sub
End If

If Weekday(Date1, 2) <> "1" Then
    MsgBox "vous devez saisir un lundi"
    Me.Date1.SetFocus
Else
    With Worksheets("2021")
        DernLigne = Range("D" & Rows.Count).End(xlUp).Row
        For Lig1 = 3 To DernLigne
            If .Cells(Lig1, 4).Value = MyDate Then
                MsgBox (.Cells(Lig1, 4).Row) & " - " & .Cells(Lig1, 4).Value& & " - " & .Cells(Lig1, 1).Value
                Depart = .Cells(Lig1, 4).Row
            End If
        Next Lig1
    End With

For k = Depart To 374 Step 7
        If wrsTarget.Cells(k, 1) = 1 Then
            wrsSource.Range("e3:Cc9").Copy wrsTarget.Range("E" & k)
        End If
        If wrsTarget.Cells(k, 1) = 2 Then
            wrsSource.Range("e10:Cc16").Copy wrsTarget.Range("E" & k)
        End If
        If wrsTarget.Cells(k, 1) = 3 Then
            wrsSource.Range("e17:Cc23").Copy wrsTarget.Range("E" & k)
        End If
        If wrsTarget.Cells(k, 1) = 4 Then
            wrsSource.Range("e24:Cc30").Copy wrsTarget.Range("E" & k)
        End If
Next k
Application.CutCopyMode = False
End If
End Sub

Code qui bug :

For k = Depart To 374 Step 7
        If wrsTarget.Cells(k, 1) = 1 Then
            wrsSource.Range("e3:Cc9").Copy wrsTarget.Range("E" & k)
        End If
        If wrsTarget.Cells(k, 1) = 2 Then
            wrsSource.Range("e10:Cc16").Copy wrsTarget.Range("E" & k)
        End If
        If wrsTarget.Cells(k, 1) = 3 Then
            wrsSource.Range("e17:Cc23").Copy wrsTarget.Range("E" & k)
        End If
        If wrsTarget.Cells(k, 1) = 4 Then
            wrsSource.Range("e24:Cc30").Copy wrsTarget.Range("E" & k)
        End If
Next k

J'ai essayé ca mais ca plante

If wrsTarget.Cells(k, 1) = 1 Then
            wrsSource.Range("e3:Cc9").Copy wrsTarget.Range("E" & k)
wrsSource.Range("e3:Cc9")wrsSource.Range("e3:Cc9").Paste:=xlPasteValues
End If

Pensez-vous que ce soit possible d'éviter cette surcharge de mise en forme conditionnelle ?

Je vous remercie de votre aide

Cordialement

Le 10/09/2020 à 16:13

Bonjour

Essayez comme ceci

For k = Depart To 374 Step 7
    Select Case wrsTarget.Cells(k, 1)
        Case Is = 1: wrsSource.Range("e3:Cc9").Copy
        Case Is = 2: wrsSource.Range("e10:Cc16").Copy
        Case Is = 3: wrsSource.Range("e17:Cc23").Copy
        Case Is = 4: wrsSource.Range("e24:Cc30").Copy
    End Select
    wrsTarget.Range("E" & k).PasteSpecial Paste:=xlPasteValues
Next k
Application.CutCopyMode = False

Cordialement

Le 10/09/2020 à 16:14

Bonjour sylvainpyc, le forum,

As-tu essayé ceci: .......pour coller les valeurs uniquement...

For k = Depart To 374 Step 7
        If wrsTarget.Cells(k, 1) = 1 Then
            wrsSource.Range("e3:Cc9").Copy 
            wrsTarget.Range("E" & k).PasteSpecial Paste:=xlPasteValues
        End If
        If wrsTarget.Cells(k, 1) = 2 Then
            wrsSource.Range("e10:Cc16").Copy 
            wrsTarget.Range("E" & k).PasteSpecial Paste:=xlPasteValues
        End If
        If wrsTarget.Cells(k, 1) = 3 Then
            wrsSource.Range("e17:Cc23").Copy 
            wrsTarget.Range("E" & k).PasteSpecial Paste:=xlPasteValues
        End If
        If wrsTarget.Cells(k, 1) = 4 Then
            wrsSource.Range("e24:Cc30").Copy 
            wrsTarget.Range("E" & k).PasteSpecial Paste:=xlPasteValues
        End If
Next k

Cordialement,

Le 10/09/2020 à 16:27

Bonjour à tous,

Une autre solution, que je n'ai cependant pas testée, semblable à celles de Dan et Xorsankukai :

Dim Valeur as byte

For k = Depart To 374 Step 7
    Valeur = wrsTarget.Cells(k, 1).value

    with wrsSource.Range(cells(7*(Valeur-1)+3, 5), cells(7*(Valeur-1)+9,81))
        .Copy
        wrsTarget.Range("E" & k).resize(.rows.count,.columns.count).pastespecial paste:=xlpastevalues
    end with
Next k
7*(Valeur-1)+3 permet de renvoyer 3, 10, 17, 24 quand Valeur vaut 1, 2, 3, 4

7*(Valeur-1)+9 renvoie 9, 16, 23, 30 suivant Valeur également

Les 5 et 81 indiquent les colonnes E et CC

.resize(.rows.count,.columns.count) permet de redimensionner la Target aux nombres de lignes et colonnes de la Source. C'est une contrainte du pastespecial si je ne dis pas de bêtises.

Cordialement,

Le 10/09/2020 à 16:29

Il n'y a pas de contraintes avec le collage spécial alors ?

Le 10/09/2020 à 16:38

J'ai ce message d'erreur sur cette ligne

"Pour ce faire la taille des cellules fusionnées doit être identiques"

wrsTarget.Range("E" & k).PasteSpecial Paste:=xlPasteValues

Alors qu'avec le code de base le collage se faisait quand même

????

Le 10/09/2020 à 16:40

Et ce message

"la méthode range de l'objet a échoué"

wrsTarget.Range

pour le code de 3GB

Le 10/09/2020 à 16:42

Oui, j'ai édité mon commentaire entre temps. J'ai mis une parenthèse en trop, désolé !

Edit : Mais ma modification ne portait pas sur cette ligne cependant...

Le 10/09/2020 à 16:45

A essayer sinon :

Dim Valeur as byte
Dim MaTarget as range

For k = Depart To 374 Step 7
    Valeur = wrsTarget.Cells(k, 1).value

    with wrsSource.Range(cells(7*(Valeur-1)+3, 5), cells(7*(Valeur-1)+9,81))
        .Copy
        Set MaTarget = wrsTarget.Range("E" & k).resize(.rows.count,.columns.count)
        MaTarget.Pastespecial paste:=xlpastevalues
        Set MaTarget = Nothing
    end with
Next k
Le 10/09/2020 à 17:03

même message sur cette ligne

With wrsSource.Range(Cells(7 * (Valeur - 1) + 3, 5), Cells(7 * (Valeur - 1) + 9, 81))

Le 10/09/2020 à 17:07

A première vue, je ne vois pas de problème à cette ligne

wrsSource.Range(cells(7*(Valeur-1)+3, 5), cells(7*(Valeur-1)+9,81))

Mais si Valeur (càd wrsTarget.Cells(k, 1).value) valait 0 par exemple, ça pourrait bloquer. J'ai considéré que Valeur valait 1, 2, 3 ou 4.

Le 10/09/2020 à 17:11

Nouvel essai :

Dim Valeur as byte

For k = Depart To 374 Step 7

    Valeur = wrsTarget.Cells(k, 1).value

    if Valeur > 0 then
        with wrsSource.Range(cells(7*(Valeur-1)+3, 5), cells(7*(Valeur-1)+9,81))
            .Copy
            wrsTarget.Range("E" & k).resize(.rows.count,.columns.count).pastespecial paste:=xlpastevalues
        end with
    end if

Next k
Le 10/09/2020 à 17:19

Toujours le même message sur cette ligne

With wrsSource.Range(Cells(7 * (Valeur - 1) + 3, 5), Cells(7 * (Valeur - 1) + 9, 81))

???

Le 10/09/2020 à 17:38

Quelle valeur peut bien avoir wrsTarget.Cells(k, 1).value suivant les k ?

Avez-vous bien mis ce bout de code au sein de votre code à vous ? Car sinon, WrsSource et WrsTarget ne sont pas initialisés...

Le 10/09/2020 à 17:55

Voici tout mon code

Private Sub Trame1_Click()
Dim wrsSource As Worksheet
Dim wrsTarget As Worksheet
Set wrsSource = Worksheets("Trame de base")
Set wrsTarget = Worksheets("2021")
Dim CduDate As String
Dim MyDate As Date
     Application.CutCopyMode = False

CduDate = Date1.Value
If IsDate(CduDate) = True Then
MyDate = Format(CduDate, "dd/mm/yyyy")
Else
MsgBox "Entrer une date valide"
Exit Sub
End If

If Weekday(Date1, 2) <> "1" Then
    MsgBox "vous devez saisir un lundi"
    Me.Date1.SetFocus
Else
    With Worksheets("2021")
        DernLigne = Range("D" & Rows.Count).End(xlUp).Row
        For Lig1 = 3 To DernLigne
            If .Cells(Lig1, 4).Value = MyDate Then
                MsgBox (.Cells(Lig1, 4).Row) & " - " & .Cells(Lig1, 4).Value& & " - " & .Cells(Lig1, 1).Value
                Depart = .Cells(Lig1, 4).Row
            End If
        Next Lig1
    End With

Dim Valeur As Byte

Dim MaTarget As Range

For k = Depart To 374 Step 7

    Valeur = wrsTarget.Cells(k, 1).Value

    If Valeur > 0 Then
        With wrsSource.Range(Cells(7 * (Valeur - 1) + 3, 5), Cells(7 * (Valeur - 1) + 9, 81))
            .Copy
            wrsTarget.Range("E" & k).Resize(.Rows.Count, .Columns.Count).PasteSpecial Paste:=xlPasteValues
        End With
    End If

Next k

Application.CutCopyMode = False
End If
End Sub
Le 10/09/2020 à 18:53

Re

Je lis vos échanges mais une question vous êtes sur quelle feuille de votre fichier quand vous exécutez le code ?

Le 10/09/2020 à 19:07

dans la feuille 2021

Voici mon fichier

J'ai effacé des feuilles, des userforms

et des lignes/colonnes pour qu'il soit moins lourd et pouvoir le transférer

3salaries2021-construction-1009d.zip (425.21 Ko)
Rechercher des sujets similaires à "copier mise forme"