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

  • Initiateur de la discussion Initiateur de la discussion cd95
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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

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
 
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
 
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 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).
 
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

•>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
 
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

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.
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Retour