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

cd95

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

Pièces jointes

  • Copier tableau vers un nouveau classeur.xlsm
    55.8 KB · Affichages: 14

Pounet95

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

Copie Original Saisie.PNG Copie saisie.PNG
 

cd95

XLDnaute Occasionnel

Pounet95

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

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

Staple1600

XLDnaute Barbatruc
Bonjour le fil, cd95, Pounet95

J'ai pondu, je poste ;)
(Cela pourra toujours servir)
VB:
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

XLDnaute Occasionnel
Bonjour le fil, cd95, Pounet95

J'ai pondu, je poste ;)
(Cela pourra toujours servir)
VB:
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

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

cd95

XLDnaute Occasionnel
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 ;)
Re

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

Staple1600

XLDnaute Barbatruc
Re

J'avais oublié que j'étais confiné ;)
Alors CKADO ;)
VB:
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

XLDnaute Occasionnel
Re

J'avais oublié que j'étais confiné ;)
Alors CKADO ;)
VB:
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.
 

Discussions similaires