Copiage d'une plage de cellule en conservant règle de surbrillance

philippe_chalon01 · 31 Août 2016

Bonjour,
J'ai une macro qui copie une plage de cellule d'une feuille et qui va coller cette plage dans un nouveau fichier.
Cette plage de cellule contient des règles de surbrillance : vert si comprise entre telle et telle valeur, rouge si non comprise.
Seulement lors du copiage, les règle de surbrillance se conservent et cela est bien, cependant il met tout en rouge, même les valeurs positive...
Je ne comprends pas le problème puisque quand je vérifie les règles de surbrillance elles n'ont pas changé.
Est ce que je devrais alors modifier la macro pour qu'elle copie seulement la mise en forme (donc la couleur) des cellules et ne pas copier les règles de surbrillance ?

J'ai de plus un autre problème avec ce fichier. En effet lorsqu'il crée le nouveau document, j'ai choisi comme chemin de sauvegarde le même chemin que celui du fichier source mais pourtant il sauvegarde le fichier dans mes documents...
Merci à ceux qui m'aideront

philippe_chalon01 · 31 Août 2016

En effet, j'étais tellement absorbé par les macros que je ne pensais plus qu'à ça, à en oublier les fonctions toutes simples...
Je viens d'apprendre que je dois modifier tout mon fichier, je vais essayer de faire seul mais j'aurais peut être besoin de ton aide demain.
Merci,
bonne soirée

philippe_chalon01 · 31 Août 2016

En faite non ce n'est pas possible de le faire avec de simples formules puisque la date et l'heure se met automatiquement à jour, or je veux que ça ne bouge pas après la saisie.
Je vais mieux expliquer :
J'aimerais que lorsque par exemple la cellule G13 est remplit, que la cellule H13 affiche la date et la cellule J13 l'heure. Et ceci pour toute la plage de cellule G13:G63
Merci encore

vgendron · 31 Août 2016

il faut donc que tu utilises l'évènement change de la feuille "Saisie"

code à placer sur la feuille en question.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Range("G13:G63"), Target) Is Nothing Then
    Target.Offset(0, 1) = Date
    Target.Offset(0, 3) = Time
End If
End Sub

philippe_chalon01 · 1 Septembre 2016

Bonjour vgendron,
Cela marche bien lorsque je rentre une valeur en G13, il affiche la date en H13 et l'heure I13.
Cependant lorsque j'efface la date en G13, la date et l'heure en H13 et I13 ne s'efface pas, mais en plus la date s'affiche en J13 et l'heure en K13..
Lorsque je lance la macro pour créer le nouveau fichier, étant donné qu'il efface toute la colonne G, cela fait planter le fichier car toute la feuille se remplit de date et heure.
Pour info j'avais légèrement modifier ton code pour leur donner le bon format

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Range("G13:G63"), Target) Is Nothing Then
Target.Offset(0, 1) = Date
Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
Target.Offset(0, 2) = Time
Target.Offset(0, 2).NumberFormat = "hh:mm"
End If
End Sub

vgendron · 1 Septembre 2016

Hello

pour effacer jour et heure si il n'y a rien en colonne G, modifier le code comme ceci

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

If Not Intersect(Range("G13:G63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 3) = Time
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 3) = ""
    End If
End If
End Sub

pour le problème de mise à jour quand la colonne G est effacée.
il faut ajouter
en début de macro: application.enableevents=false
et en fin de macro: application.enableevents=true

Je pense que ca devrait regler le problème.. à tester

philippe_chalon01 · 1 Septembre 2016

Bonjour vgendron.
Pour effacer jour et heure ta macro marche parfaitement,
Cependant le problème de mis à jour est toujours à moitié présent. Il n'affiche plus l'heure et la date dans toute la feuille mais le fichier mets 2 minutes à s'exécuter et fini par m'afficher une heure "Erreur d'exécution '13' : Incompatibilité de type. Mais sinon il marche, donc c'est bizarre.
Je te joins le fichier si ça peut t'aider,
En tout cas encore merci de ton aide

vgendron · 1 Septembre 2016

pour l'heure. c'est offset(0,2) qu'il faut utiliser et pas offset(0,3) parce que tu as fusionné deux cellules

Code:

Private Sub Worksheet_Change(ByVal Target As Range)

Application.EnableEvents = False

If Not Intersect(Range("G13:G63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If
   
If Not Intersect(Range("T13:T63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If


If Not Intersect(Range("AT13:AT63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If

If Not Intersect(Range("BG13:BG63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If

If Not Intersect(Range("BT13:BT63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If

If Not Intersect(Range("CG13:CG63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If
   
If Not Intersect(Range("CT13:CT63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If

If Not Intersect(Range("DG13:DG63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If

If Not Intersect(Range("DT13:DT63"), Target) Is Nothing Then
    If Target <> "" Then
        Target.Offset(0, 1) = Date
        Target.Offset(0, 1).NumberFormat = "dd/mm/yyyy"
        Target.Offset(0, 2) = Time
        Target.Offset(0, 2).NumberFormat = "hh:mm"
    Else
        Target.Offset(0, 1) = ""
        Target.Offset(0, 2) = ""
    End If
End If
   
Application.EnableEvents = True

End Sub

et pour l'enable events, c'est dans l'autre macro qu'il faut le mettre..

Code:

Sub placementcote2()
Dim c As Single
Application.EnableEvents = False

c = Range("A2").Value

'pour chaque poste de 2 à 11
For i = 1 To 10
    If c >= Cells(1, 6 + (i - 1) * 13).Value And c <= Cells(2, 6 + (i - 1) * 13).Value Then
        Cells(Rows.Count, (6 + (i - 1) * 13) - 3).End(xlUp).Offset(1, 0) = c
        Cells(Rows.Count, (6 + (i - 1) * 13) - 3).End(xlUp).Offset(0, 1) = Date
        Cells(Rows.Count, (6 + (i - 1) * 13) - 3).End(xlUp).Offset(0, 1).NumberFormat = "dd/mm/yyyy"
   
        Cells(Rows.Count, (6 + (i - 1) * 13) - 3).End(xlUp).Offset(0, 2) = Time
        Cells(Rows.Count, (6 + (i - 1) * 13) - 3).End(xlUp).Offset(0, 2).NumberFormat = "hh:mm"
    End If
   
Next i
Range("A2").ClearContents
Range("A2").Activate
Application.EnableEvents = True
End Sub

philippe_chalon01 · 1 Septembre 2016

Bonjour,
Toujours le même problème, même en plaçant bien les Application.EnableEvents . Le fichier met 2 minutes et mets un message d'erreur à la fin. Mais ça marche et c'est le plus important.
Merci beaucoup, bonne journée

philippe_chalon01 · 1 Septembre 2016

Je viens d'essayer sans l'ajout des dates et la création de fichier est toujours aussi longue...
Je pense que cela vient en faite des nombreuses MFC...

vgendron · 1 Septembre 2016

Bizarre..
chez moi , ca ne plante pas..
par contre. effectivement. c'est un peu long (5s.. et pas 2mn)
ce qui est long. c'est la partie ou tu réinitialises TOUS les check box.. de TOUS les postes..

Code:

With S_WKB.Sheets("Saisie")
Dim Shp As Shape
For Each Shp In Sheets("Saisie").Shapes
    If Shp.FormControlType = xlCheckBox Then
        Shp.DrawingObject.Value = False
    End If
Next Shp
End With

PJ la version 3 qui ne plante pas chez moi

philippe_chalon01 · 1 Septembre 2016

Je pense que nos ordinateurs ne doivent pas avoir la même puissance alors ^^
Ceci dit, merci beaucoup, le fichier marche et c'est vraiment le plus important.
Bonne continuation et bonne fin de journée

philippe_chalon01 · 1 Septembre 2016

Re-Bonjour vgendron,
Tout petit et dernier ultime service à te demander.
J'aimerais qu'il s'enregistre au format PDF et qu'il tienne sur une page complète si possible.
Que faut il modifier dans le code d'enregistrement ?
Merci beaucoup

vgendron · 1 Septembre 2016

alors.. pour l'enregistrement format pdf. c'est un truc que je ne maitrise pas du tout..
mais l'enregistreur de Macro me donne ce bout de code
Chemin est déjà défini dans ton code
il faut juste ajouter une ligne pour le NFicPdf
tout comme tu as fait pourNFic
NFicPdf = S_WKB.Worksheets(1).Range("I2").Value & ".pdf"

Code:

Range("A1:L59").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Chemin & "\" & NFicPdf, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

à voir comment et où il faut intégrer dans le code déjà existant..

vgendron · 1 Septembre 2016

Ca donnerait un truc comme ca..

Code:

Sub ColleEtSauve1()
Dim D_WKB As Workbook, Chemin As String, NFic As String
Dim S_WKB As Workbook: Set S_WKB = ThisWorkbook
Dim MaPlage As Range

Chemin = S_WKB.Path
NFicXls = S_WKB.Worksheets(1).Range("I2").Value & ".xls"
NFicPdf = S_WKB.Worksheets(1).Range("I2").Value & ".pdf"
ColDépart = "I"

'à partir de la cellule contenant le nom du fichier à créer
Set MaPlage = S_WKB.Worksheets(1).Columns(ColDépart).Resize(, 12).Offset(0, -6)
first = MaPlage.Column
MaPlage.Select

Application.ScreenUpdating = False
MaPlage.Copy
Set D_WKB = Workbooks.Add(xlWBATWorksheet)
With D_WKB.ActiveSheet
    .Paste (.Columns(first))
    With .UsedRange
        .Value = .Value
    End With
    .Rows("1:4").Delete
    .Columns("A").Resize(, first - 1).Delete
End With
'sauvegarde en xls
D_WKB.SaveAs Chemin & "\" & NFicXls

'selection de la zone à exporter en pdf
Range("A1:L59").Select
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
Chemin & "\" & NFicPdf, Quality:= _
xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Application.CutCopyMode = False
Application.ScreenUpdating = True

With S_WKB.Sheets("Saisie")
Dim Shp As Shape
For Each Shp In Sheets("Saisie").Shapes
    If Shp.FormControlType = xlCheckBox Then
        Shp.DrawingObject.Value = False
    End If
Next Shp
End With

S_WKB.Sheets("Saisie").Range("F1,F2,D10,F10,H10,J10").ClearContents
S_WKB.Sheets("Saisie").Range("I2:L2").ClearContents
S_WKB.Sheets("Saisie").Range("D8:J8").ClearContents
S_WKB.Sheets("Saisie").Range("C9:J9").ClearContents
S_WKB.Sheets("Saisie").Range("L8:N8").ClearContents
S_WKB.Sheets("Saisie").Range("L9:N9").ClearContents
S_WKB.Sheets("Saisie").Range("C13:N63").ClearContents
Application.EnableEvents = True
End Sub

philippe_chalon01 · 2 Septembre 2016

Bonjour Vgendron, ton code ne marche pas mais je l'ai modifié un peu et maintenant il marche 🙂
Mais j'ai toujours le problème suivant : il imprime en PDF sur 4 pages alors que j'aimerais que ce soit sur une seule page. J'ai vu sur différent forum qu'il fallait définir la zone d'impression, et c'est ce que j'ai fait mais il continue de mettre sur 4 pages. Je me demande alors si il y a quelque chose qui n'est pas mis dans le bon ordre dans mon code :

Sub ColleEtSauve1()
Dim Chemin As String, NFic As String
Dim S_WKB As Workbook: Set S_WKB = ThisWorkbook

Chemin = S_WKB.Path
NFic = S_WKB.Worksheets(1).Range("J2").Value & ".pdf"

'selection de la zone à exporter en pdf
Range("C4:N64").Select
ActiveSheet.PageSetup.PrintArea = "$C$4:$N$64"
Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Chemin & "\" & NFic, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=True

Application.CutCopyMode = False
Application.ScreenUpdating = True

With S_WKB.Sheets("Saisie")
Dim Shp As Shape
For Each Shp In Sheets("Saisie").Shapes
If Shp.FormControlType = xlCheckBox Then
Shp.DrawingObject.Value = False
End If
Next Shp
End With

S_WKB.Sheets("Saisie").Range("F1,F2,D10,F10,H10,J10").ClearContents
S_WKB.Sheets("Saisie").Range("I2:L2").ClearContents
S_WKB.Sheets("Saisie").Range("D8:J8").ClearContents
S_WKB.Sheets("Saisie").Range("C9:J9").ClearContents
S_WKB.Sheets("Saisie").Range("L8:N8").ClearContents
S_WKB.Sheets("Saisie").Range("L9:N9").ClearContents
S_WKB.Sheets("Saisie").Range("C13:N63").ClearContents
Application.EnableEvents = True
End Sub

Copiage d'une plage de cellule en conservant règle de surbrillance

philippe_chalon01

XLDnaute Nouveau

Pièces jointes

philippe_chalon01

XLDnaute Nouveau

philippe_chalon01

XLDnaute Nouveau

vgendron

XLDnaute Barbatruc

philippe_chalon01

XLDnaute Nouveau

vgendron

XLDnaute Barbatruc

philippe_chalon01

XLDnaute Nouveau

Pièces jointes

vgendron

XLDnaute Barbatruc

philippe_chalon01

XLDnaute Nouveau

philippe_chalon01

XLDnaute Nouveau

vgendron

XLDnaute Barbatruc

Pièces jointes

philippe_chalon01

XLDnaute Nouveau

philippe_chalon01

XLDnaute Nouveau

vgendron

XLDnaute Barbatruc

vgendron

XLDnaute Barbatruc

philippe_chalon01

XLDnaute Nouveau

Discussions similaires

Copiage d'une plage de cellule en conservant règle de surbrillance

XLDnaute Nouveau

Pièces jointes

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Nouveau

Pièces jointes

XLDnaute Barbatruc

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

Pièces jointes

XLDnaute Nouveau

XLDnaute Nouveau

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Nouveau

Discussions similaires

Privacy & Transparency

Privacy & Transparency