Microsoft 365 COPIER COLLER VALEUR D'UNE FEUILLE EXCEL DANS UN NOUVEAU CLASSEUR

[mapapiotmi]

Bonjour,

Je ne connais VBA qu'au travers de l'enregistreur de macros.

Je souhaite copier/coller une partie de feuille excel (ou la feuille entière) dans un nouveau classeur et enregistrer ce nouveau classeur avec le même nom que le classeur source (en y ajoutant une info qui le distingue : -2 ou -valeur), dans le même dossier.

Merci à vous de votre aide précieuse

Bien à vous

Martine

 

[Staple1600]

Bonsoir le fil, mapapiotmi

mapapiotmi
Une première ébauche (à peaufiner)

Public t
Sub test()
'recopie toute la feuille
CopieAuChoix ActiveSheet
End Sub
Sub test2()
'recopie la sélection de cellule de la feuille
CopieAuChoix ActiveSheet, False
End Sub
Private Sub CopieAuChoix(Feuille As Worksheet, Optional Tout As Boolean = True)
Dim strPath As String, WBK As Workbook
strPath = ThisWorkbook.Path & "\"
NFic = Feuille.Name & Format(Now, "ddmmyyyyhhmmss") & "_valeur.xlsx"
Select Case Tout
Case True 'copie toute la feuille
    Feuille.Copy
    With ActiveWorkbook
    .Sheets(1).UsedRange = .Sheets(1).UsedRange.Value
    .SaveAs strPath & NFic, 51
    .Close True
End With
Case False 'copie la sélection en cours
    t = Feuille.Range(Selection.Address).Value
    Set WBK = Workbooks.Add(xlWBATWorksheet)
    WBK.Sheets(1).Cells(1).Resize(UBound(t, 1), UBound(t, 2)) = t
    WBK.SaveAs strPath & NFic, 51
    WBK.Close True
End Select
End Sub

EDITION : Bonsoir job75

 

[job75]

Bonsoir mapapiotmi, bienvenue sur XLD, salut JM,

Mettez cette macro où vous voulez dans le VBA du fichier (Alt+F11) et exécutez-la (Alt+F8) :

Sub CreerFichier()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Copy
With ThisWorkbook
    ActiveWorkbook.SaveAs Left(.FullName, InStrRev(.FullName, ".") - 1) & "-2", 51 'fichier .xlsx
End With
ActiveWorkbook.Close
End Sub

A+

 

[mapapiotmi]

Bonsoir mapapiotmi, bienvenue sur XLD, salut JM,

Mettez cette macro où vous voulez dans le VBA du fichier (Alt+F11) et exécutez-la (Alt+F8) :

Sub CreerFichier()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
ActiveSheet.Copy
With ThisWorkbook
    ActiveWorkbook.SaveAs Left(.FullName, InStrRev(.FullName, ".") - 1) & "-2", 51 'fichier .xlsx
End With
ActiveWorkbook.Close
End Sub

A+

 

[mapapiotmi]

Merci pour cette macro très courte
Parc contre, le fichier a un mot de passe et il faudrait le désactiver avant d'enregistrer et faire un "copier coller valeur avec mise en forme "de toute la feuille.
j'ai essayer de l'ajouter mais cela ne fonctionne pas

Merci encore à vous

Martine

 

[mapapiotmi]

Merci pour cette macro très courte
Parc contre, le fichier a un mot de passe et il faudrait le désactiver avant d'enregistrer et faire un "copier coller valeur avec mise en forme "de toute la feuille.
j'ai essayer de l'ajouter mais cela ne fonctionne pas

Merci encore à vous

Martine

 

[job75]

Bonjour mapapiotmi, le forum,

Adaptez le mot de passe "toto" :

Sub CreerFichier()
Dim F As Worksheet
Set F = ActiveSheet 'à adapter
Application.ScreenUpdating = False
Application.DisplayAlerts = False
F.Copy 'nouveau document
With ActiveSheet
    .Protect "toto", UserInterfaceOnly:=True 'mot de passe à adapter
    .UsedRange = F.UsedRange.Value 'copie les valeurs
    .Parent.SaveAs Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, ".") - 1) & "-2", 51 'fichier .xlsx
    .Parent.Close
End With
End Sub

A+

 

[Staple1600]

Bonsoir le fil, Martine, job75

Martine
C'est toujours plaisant d'être ignoré par le demandeur...
(cf message#2)
C'est très motivant pour la suite.
Donc merci Martine, pour ce superbe moment d’invisibilité

NB: Le message#2 faisait pourtant lui aussi le copier valeurs/seules comme demandé.