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

[philippe_chalon01]

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

 

[vgendron]

Hello

pour la sauvegarde, tu dois spécifier le chemin complet..

D_WKB.SaveAs Chemin & "\" & NFic

pour le reste. je regarde. mais déjà. ton code est très long et répétitif..
il est tout à fait possible de le raccourcir avec une simple boucle.
je reviens vers toi dès que je finalise

 

[philippe_chalon01]

Bonjour vgendron,
Merci de ton aide.
Très bien je spécifierai le chemin alors.
Et oui je sais désolé pour le codage mais je fais comme je peux, je ne suis pas très doué.
Ne t'embête pas à essayer de faire des boucles, mon fichier est fini.
Ce qui m'ennuie juste est le faite que la surbrillance n'est pas conservée.
Merci

 

[vgendron]

voici..

Sub placementcote2()
Dim c As Single

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, 3) = Time
        Cells(Rows.Count, (6 + (i - 1) * 13) - 3).End(xlUp).Offset(0, 3).NumberFormat = "hh:mm"
    End If
Next i
Range("A2").ClearContents
Range("A2").Activate
End Sub

Note: il faut déplacer le petit tableau Val Min et Val max du poste 2 vers la gauche.. pour qu'il soit alligné sur la colonne C. comme les autres postes

 

[vgendron]

pour le problème de surbrillance..
dans ta feuille d'originie, la MFC teste les valeurs en ligne 11 (D11 et F11)
quand tu copies dans un nouveau classeur..la ligne 11 devient la ligne 8.. sauf que la MFC reste sur la ligne 11.. donc ca ne marche plus..

soit. il faut refaire la MFC?? soit coller la fiche de poste pour garder les memes numéro de lignes..?

 

[philippe_chalon01]

Merci pour ton code !
Et oui j'ai réussi à voir d'ou venait le problème de la MFC.
Dans ce cas est-ce que ce serait possible de copier entièrement en faisant disparaître Valeur Min, Valeur Max, Nom Fichier et le bouton ?
De plus est-ce qu'il serait possible de conserver la largeur des colonnes et des lignes lors du collage ? Merci
Merci de ton aide

 

[vgendron]

Solution pour contourner le pb..
tu commences par copier coller au meme endroit que la source. cad en range C4
et ensuite. tu supprimes les lignes et colonnes. et la. la MFC s'adapte toute seule

With D_WKB.ActiveSheet
    .Paste (.Range("C4"))
        With .UsedRange
            .Value = .Value
        End With
End With
Rows("1:3").Delete
Columns("A:B").Delete
Application.CutCopyMode = False
D_WKB.SaveAs Chemin & "\" & NFic
Application.ScreenUpdating = True

 

[vgendron]

pour garder la taille des colonnes..
en changeant juste la zone de copie..

Set MaPlage = S_WKB.Worksheets(1).Columns("C:N")

Chemin = S_WKB.Path
NFic = S_WKB.Worksheets(1).Range("I2").Value & ".xls"
Application.ScreenUpdating = False
MaPlage.Copy
Set D_WKB = Workbooks.Add(xlWBATWorksheet)
With D_WKB.ActiveSheet
    .Paste (.Columns("C"))
        With .UsedRange
            .Value = .Value
        End With
End With
Rows("1:4").Delete
Columns("A:B").Delete

 

[philippe_chalon01]

Merci de ton aide.
Seulement cela marche uniquement pour le poste numéro 2.
Pour les autres postes la MFC reste décalée.
Aurais-tu une idée pour combler ce problème ?
En tout cas merci ta boucle marche parfaitement.

 

[philippe_chalon01]

Est ce que ce ne serait pas mieux de faire une mise en forme conditionnelle en VBA pour ne pas être embêté ? Et ensuite lors de la copie , seulement copié la mise en forme (les couleurs)
J'ai beau chercher je ne vois pas de solution avec la MFC normale...

 

[vgendron]

pour les postes suivants..
en fait. il faut reprendre celui ci comme base

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
NFic = S_WKB.Worksheets(1).Range("I2").Value & ".xls"
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

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


S_WKB.Sheets("Saisie").Range("F1,F2,D10,F10,H10,J10,L10,N10").ClearContents
S_WKB.Sheets("Saisie").Range("I2:L2").ClearContents
S_WKB.Sheets("Saisie").Range("D8:G8").ClearContents
S_WKB.Sheets("Saisie").Range("C9:G9").ClearContents
S_WKB.Sheets("Saisie").Range("I8:N8").ClearContents
S_WKB.Sheets("Saisie").Range("I9:N9").ClearContents
S_WKB.Sheets("Saisie").Range("C13:N63").ClearContents
End Sub

et comme tu as crée une macro pour chaque poste..
il faut que tu adaptes à chaque fois ces deux lignes en début de macro

NFic = S_WKB.Worksheets(1).Range("I2").Value & ".xls"
ColDépart = "I"

pour le poste 3 ca va devenir V2 et V etc etc

est ce que. si je te propose une macro unique (donc. un seul bouton) qui commence par te demander quel numéro de poste tu souhaites sauvegarder. ca t'irait?

 

[vgendron]

Début de réponse

Sub ColleEtSauveX()

Dim D_WKB As Workbook, Chemin As String, NFic As String
Dim S_WKB As Workbook: Set S_WKB = ThisWorkbook
Dim MaPlage As Range
'intialisation du numéro de poste à 0 pour etre sur de rentrer dans le while
Numposte = 0

While Numposte < 2 Or Numposte > 11
    Numposte = CInt(InputBox("quel numéro de poste souhaitez vous enregisrer? entre 2 et 11"))
Wend


Chemin = S_WKB.Path
'on récupère le nom du fichier
NFic = S_WKB.Worksheets(1).Cells(2, (9 + (Numposte - 2) * 13)) & ".xls"
'on récupère le numéro de la première colonne du tableau à sauvegarder
ColDépart = 9 + (Numposte - 2) * 13

'à 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
End With
Rows("1:4").Delete
Columns("A").Resize(, first - 1).Delete
Application.CutCopyMode = False
D_WKB.SaveAs Chemin & "\" & NFic
Application.ScreenUpdating = True

'cette partie est à modifier également pour que ca s'adapte en fonction du numéro de poste sélectionné
S_WKB.Sheets("Saisie").Range("F1,F2,D10,F10,H10,J10,L10,N10").ClearContents
S_WKB.Sheets("Saisie").Range("I2:L2").ClearContents
S_WKB.Sheets("Saisie").Range("D8:G8").ClearContents
S_WKB.Sheets("Saisie").Range("C9:G9").ClearContents
S_WKB.Sheets("Saisie").Range("I8:N8").ClearContents
S_WKB.Sheets("Saisie").Range("I9:N9").ClearContents
S_WKB.Sheets("Saisie").Range("C13:N63").ClearContents
End Sub

 

[philippe_chalon01]

Non c'est parfait et ça fonctionne parfaitement.
Je te remercie beaucoup,
Bonne fin de journée à toi.

 

[philippe_chalon01]

Rebonjour vgendron, j'ai une dernière petite question :
J'aimerais que lorsque une des cellules de la plage G13:G63 est remplit, que la date et l'heure vienne s'afficher dans les colonnes suivantes.
Merci encore de ton aide

 

[vgendron]

Re
pas sur de comprendre
avec une simple formule
en H13=SI(ESTNUM(G13);D13;"")
en I13=SI(ESTNUM(G13);F13;"")

et tu tires vers le bas..??