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

P

philippe_chalon01

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

Pièces jointes

  • Essai.xlsm
    61.2 KB · Affichages: 39
Trier par date Trier par votes
P

philippe_chalon01

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif
P

philippe_chalon01

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
P

philippe_chalon01

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
P

philippe_chalon01

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

Pièces jointes

  • ESSAI.xlsm
    1 MB · Affichages: 57
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
vgendron

vgendron

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

Pièces jointes

  • ESSAI Rev3.xlsm
    933 KB · Affichages: 45
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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..
 
Vote positif 0 Vote négatif
vgendron

vgendron

XLDnaute Barbatruc
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
 
Vote positif 0 Vote négatif
P

philippe_chalon01

XLDnaute Nouveau
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
 
Vote positif 0 Vote négatif

Discussions similaires

A
  • Résolu(e)
XL 2013 mise en surbrillance sous condition
Réponses
8
Affichages
338
ANTONY34200
A
C
  • Résolu(e)
XL 2021 Duplication d'onglets dans un nouveau fichier et enregistrement selon une cellule donnée
Réponses
7
Affichages
139
wDog66
wDog66
jcpamart
  • Question
XL 2021 Mise en forme conditionnelle à partir d'une liste
Réponses
2
Affichages
346
jcpamart
jcpamart
G
  • Question
Microsoft 365 Saut de ligne dans une cellule
Réponses
3
Affichages
158
GClaire
G
N
  • Question
Microsoft 365 Séparer en lignes des données d'une cellule
Réponses
5
Affichages
120
Cousinhub
Cousinhub
ShuarS
  • Résolu(e)
Microsoft 365 Surbrillance de cellules sur conditions
Réponses
6
Affichages
679
ShuarS
ShuarS
PatLac
  • Question
XL 2016 Envoyer une plage de cellule en pcs jointe par mail via Userform
Réponses
3
Affichages
292
PatLac
PatLac
J
  • Question
XL 2019 recuperer plage de cellule sur feuille differente
Réponses
2
Affichages
354
juju91
J
Z
  • Question
Microsoft 365 Chemin pour atteindre le stockage cloud lors d'une génération de fichier Excel
Réponses
2
Affichages
276
zedude
Z
M
  • Question
XL 2021 COPIER valeur d'une cellule pour constituer un tableau de résultats
Réponses
13
Affichages
145
matlatarte
M

Membres actuellement en ligne

6 membres et 82 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 322
Messages
2 087 267
Membres
103 502
dernier inscrit
talebafia