XL 2019 Copier tableau avec la mise en forme vers un nouveau classeur

[cd95]

Bonsoir ;

J’ai un fichier pour copier un tableau avec toute sa mise en forme vers un nouveau classeur mais sans copier le code VBA. Tout fonctionne correctement sauf qu’il ne prend pas en compte les chaînes qui contiennent un mot colorié. Y'aura-t-il une personne pour m’aider à ajouter le code qui manque pour que ça fonctionne correctement. Merci

 

[Pounet95]

Bonsoir,
Sans rien toucher, juste fait "tourner" la macro.
Windows 10 Excel 2016 32bits

 

[cd95]

Bonsoir,
Sans rien toucher, juste fait "tourner" la macro.
Windows 10 Excel 2016 32bits

Regarde la pièce jointe 1059595 Regarde la pièce jointe 1059596

Bonsoir,

J’ai bien vu vos captures et j’avais le même résultat que vous sauf que le problème n’est toujours pas résolu. La colonne des noms et prénoms est restée sans mise en forme à savoir la couleur des mots à l’intérieur des chaînes.

 

[Pounet95]

Bonsoir,
en rajoutant une ligne :
Range("A1").PasteSpecial xlPasteFormats
Range("A1").PasteSpecial xlPasteValues
Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Rajouter cette ligne
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False

 

[cd95]

Bonsoir,
en rajoutant une ligne :
Range("A1").PasteSpecial xlPasteFormats
Range("A1").PasteSpecial xlPasteValues
Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
'Rajouter cette ligne
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False

Bonjour,

Merci beaucoup à vous « Pounet95 » maintenant ça marche comme sur des roulettes. Chapeau

 

[Pounet95]

Bonjour,
Merci du retour (feedback in English in the text )
Par contre, je viens de vérifier, il faut que cette ligne soit après les autres Pastespecial !
Pourquoi ????

 

[Staple1600]

Bonjour le fil, cd95, Pounet95

J'ai pondu, je poste
(Cela pourra toujours servir)

Sub Copie_Feuille()
Dim NewWBK As Workbook
Cells(1).CurrentRegion.Copy
Set NewWBK = Workbooks.Add(1)
    With NewWBK.Sheets(1).Cells(1)
        .PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAllUsingSourceTheme
    End With
Application.CutCopyMode = False: Application.DisplayAlerts = False
NewWBK.SaveAs ThisWorkbook.Path & "\copie.xlsx", 51
NewWBK.Close True
End Sub

PS: test OK sur XL 2013

 

[cd95]

Bonjour le fil, cd95, Pounet95

J'ai pondu, je poste
(Cela pourra toujours servir)

Sub Copie_Feuille()
Dim NewWBK As Workbook
Cells(1).CurrentRegion.Copy
Set NewWBK = Workbooks.Add(1)
    With NewWBK.Sheets(1).Cells(1)
        .PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAllUsingSourceTheme
    End With
Application.CutCopyMode = False: Application.DisplayAlerts = False
NewWBK.SaveAs ThisWorkbook.Path & "\copie.xlsx", 51
NewWBK.Close True
End Sub

PS: test OK sur XL 2013

Bonjour,

Je vous remercie pour cette solution qui est mine de rien beaucoup plus propre et efficace que mon ancien code mais le seul bémol ce qu’il écrase l’ancienne sauvegarde (on ne peut pas donc garder les anciennes sauvegardes à moins de le faire manuellement ou bien sûr rajouter un code).

 

[Staple1600]

Re

•>cd95
Cette macro est fournie en l'état
Charge à son utilisateur de faire les adaptations nécessaires selon ses besoins.

On pourrait envisager l'ajout d'un InputBox pour que l'utilisateur renseigne le nom de fichier à donner à la copie par exemple.

De nombreux exemples de ce genre de choses et plus en dormance dans les archives du forum

Effectuez une recherche sur Excel Downloads...

www.excel-downloads.com

 

[cd95]

Re

•>cd95
Cette macro est fournie en l'état
Charge à son utilisateur de faire les adaptations nécessaires selon ses besoins.

On pourrait envisager l'ajout d'un InputBox pour que l'utilisateur renseigne le nom de fichier à donner à la copie par exemple.

De nombreux exemples de ce genre de choses et plus en dormance dans les archives du forum

Effectuez une recherche sur Excel Downloads...

www.excel-downloads.com

Re

Je suis tout à fait d'accord avec vous Staple1600. GRAND merci

 

[Staple1600]

Re

J'avais oublié que j'étais confiné
Alors CKADO

Sub Copie_Feuille_BIS()
Dim Nom_SVG, strPath$, NewWBK As Workbook, AWBK As Workbook:: Set AWBK = ThisWorkbook
strPath$ = ThisWorkbook.Path & "\"
Cells(1).CurrentRegion.Copy
Set NewWBK = Workbooks.Add(1)
    With NewWBK.Sheets(1).Cells(1)
        .PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAllUsingSourceTheme
    End With
Application.CutCopyMode = False: Application.DisplayAlerts = False
Nom_SVG = _
        CStr(InputBox("Merci de saisir le nom de la copie, svp.", "Backup XLSX", _
        "Copie_" & WBK_Name_Only(AWBK) & Format(Now, "_hhmmss"".xlsx""")))
NewWBK.SaveAs strPath & Nom_SVG, 51
NewWBK.Close True
End Sub
Function WBK_Name_Only(wb As Workbook) As String
WBK_Name_Only = ""
If InStr(wb.Name, ".") > 0 Then
WBK_Name_Only = Left(wb.Name, InStr(wb.Name, ".") - 1)
End If
End Function

 

[cd95]

Re

J'avais oublié que j'étais confiné
Alors CKADO

Sub Copie_Feuille_BIS()
Dim Nom_SVG, strPath$, NewWBK As Workbook, AWBK As Workbook:: Set AWBK = ThisWorkbook
strPath$ = ThisWorkbook.Path & "\"
Cells(1).CurrentRegion.Copy
Set NewWBK = Workbooks.Add(1)
    With NewWBK.Sheets(1).Cells(1)
        .PasteSpecial xlPasteColumnWidths: .PasteSpecial xlPasteAllUsingSourceTheme
    End With
Application.CutCopyMode = False: Application.DisplayAlerts = False
Nom_SVG = _
        CStr(InputBox("Merci de saisir le nom de la copie, svp.", "Backup XLSX", _
        "Copie_" & WBK_Name_Only(AWBK) & Format(Now, "_hhmmss"".xlsx""")))
NewWBK.SaveAs strPath & Nom_SVG, 51
NewWBK.Close True
End Sub
Function WBK_Name_Only(wb As Workbook) As String
WBK_Name_Only = ""
If InStr(wb.Name, ".") > 0 Then
WBK_Name_Only = Left(wb.Name, InStr(wb.Name, ".") - 1)
End If
End Function

Re
Je voudrais exprimer mon soutien le plus total à toute personne qui vient en aide pour ceux qui en ont besoin d’ailleurs comme le fait ce magnifique forum « XLD » qui parmi beaucoup de ses participants proposent gratuitement leurs ingéniosités à résoudre différents problèmes. Et en fin un grand salut au personnel soignant qui se sacrifie pour le bien commun et qui luttent contre le coronavirus avec un grand courage.