Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2021 VBA - Comment transformer un classeur enregistré en classeur non enregistré

Créer une discussion
  • Initiateur de la discussion Initiateur de la discussion Dudu2
  • 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 !

S'inscrire

Dudu2

XLDnaute Barbatruc
Bonjour,
J'aurais besoin de votre avis pour un code consistant à transformer un classeur enregistré (ayant pignon sur répertoire) en classeur non enregistré de même contenu.

Le contexte est le suivant:
Dans le cadre de la fusion des instances Excel, un classeur non encore enregistré et contenant des modifs appartient à une instance qui devra être fermée.
Il faut donc l'enregistrer en répertoire temporaire pour pouvoir le ré-ouvrir dans l'instance qui va survivre comme instance unique de fusion.
Lors de sa ré-ouverture à partir du répertoire temporaire, il faut lui restituer son statut initial de classeur non encore enregistré qu'il avait dans l'instance qui a été fermée.

Donc:
- création d'un nouveau classeur + copie du classeur temporaire + fermeture du classeur temporaire ?
- Autre solution ?
- Code ?

Merci par avance.
 
Solution
Bon, j'ai réglé le cas du code du ThisWorkbook en faisant un copier des lignes de code.
J'avais pas encore vu ton code là-dessus à cause des problèmes de TS à régler.

Cette fois c'est bon ? Finalement, c'est pas du gâteau que de dupliquer un classeur !
Trier par date Trier par votes
Bon, vu le succès du sujet, je m'y suis collé et vous donne le code.
VB: 
'-------------------------------
'Make a Workbook as new Workbook
'-------------------------------
Private Sub MakeWorkbookNew(Workbook As Workbook)
    Dim TabArray() As Long
    Dim i As Integer
  
    With Workbook
        ReDim TabArray(1 To .Worksheets.Count)
      
        For i = 1 To .Worksheets.Count
            TabArray(i) = i
        Next i
      
        .Worksheets(TabArray).Select
    End With
  
    'Creates a new Workbook with the selected Worksheets of the source Workbook 
    Worksheets.Copy
  
    'Close the source Workbook
    Workbook.Close SaveChanges:=False
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
ouis ben j'en met une 2d couche
c'est kado
VB: 
'-------------------------------
'Make a Workbook as new Workbook
'Added reimport of modules (by patricktoulon)
'-------------------------------
Sub test()
    MakeWorkbookNew ThisWorkbook, True
    
End Sub
Private Sub MakeWorkbookNew(WorkbookX As Workbook, Optional WithModule As Boolean = False)
    Dim TabArray() As Long
    Dim i As Integer
    Dim Vbcomps As VBComponents 'collection  de module
    Dim Vbcomp As VBComponent 'module
    Dim collect As Collection
    Set collect = New Collection
    With WorkbookX
        Set Vbcomps = WorkbookX.VBProject.VBComponents 'variablilise la collection de module
        ReDim TabArray(1 To .Worksheets.Count)
        
        For i = 1 To .Worksheets.Count
            TabArray(i) = i
        Next i
        
        .Worksheets(TabArray).Select
    End With
    
    
    'Creates a new Workbook with the selected source Workbook Worksheets
    Worksheets.Copy
    
    'boucle sur la collection de module standards ou classes
    For Each Vbcomp In Vbcomps
        Select Case Vbcomp.Type
            Case vbext_ct_StdModule, vbext_ct_ClassModule
                nomfichier = ThisWorkbook.Path & "\" & Vbcomp.Name & ".bas"
                If Vbcomp.Type = vbext_ct_ClassModule Then
                    nomfichier = ThisWorkbook.Path & "\" & Vbcomp.Name & ".cls"
                End If
                Vbcomp.Export nomfichier
                DoEvents
                collect.Add nomfichier
        End Select
    Next
    'si on a collectionner des chemin a"lors des module ont été exportés on les reimporte donc dans le classeur clone
    If collect.Count > 0 Then
        For i = 1 To collect.Count
            ActiveWorkbook.VBProject.VBComponents.Import collect(i)
            Kill collect(i) 'on peut supprimer le fichier
        Next
    End If
    'Close the source Workbook
    WorkbookX.Close SaveChanges:=False
End Sub
 
Vote positif 0 Vote négatif
Je vois que tu n'aimes pas faire Dim Workbook as Workbook !
Tu ne risques rien à le faire car le 1er Workbook est un nom de variable et le 2ème un type de variable.
Excel ne peut pas confondre les 2 dans les instructions.

Pareil pour Dim Collection As Collection. Et tous les autres...
 
Vote positif 0 Vote négatif
c'est une règle d'or chez moi qi j'utilise une expression vb je la sufixe d'un X
showX msgboX workbookX etc... mais en général j’évite

ps::j'avais oublié les userforms
VB: 
Sub test()
    MakeWorkbookNew ThisWorkbook, True
    
End Sub
Private Sub MakeWorkbookNew(WorkbookX As Workbook, Optional WithModule As Boolean = False)
    Dim TabArray() As Long
    Dim i As Integer
    Dim Vbcomps As VBComponents 'collection  de module
    Dim Vbcomp As VBComponent 'module
    Dim collect As Collection
    Set collect = New Collection
    With WorkbookX
        Set Vbcomps = WorkbookX.VBProject.VBComponents
        ReDim TabArray(1 To .Worksheets.Count)
        
        For i = 1 To .Worksheets.Count
            TabArray(i) = i
        Next i
        
        .Worksheets(TabArray).Select
    End With
    
    
    'Creates a new Workbook with the selected source Workbook Worksheets
    Worksheets.Copy
    
    For Each Vbcomp In Vbcomps
        Select Case Vbcomp.Type
            Case vbext_ct_StdModule
                extension = ".bas"
            Case vbext_ct_ClassModule
                extension = ".cls"
            Case vbext_ct_MSForm
                extension = ".frm"
            Case Else
                ' Ignorer ThisWorkbook et les feuilles
                GoTo NextComp
        End Select
        
        nomFichier = ThisWorkbook.Path & "\" & Vbcomp.Name & extension
        Vbcomp.Export nomFichier
        collect.Add nomFichier
        
        
    Next Comp
    If collect.Count > 0 Then
        For i = 1 To collect.Count
            ActiveWorkbook.VBProject.VBComponents.Import collect(i)
            Kill collect(i)
        Next
    End If
    'Close the source Workbook
    WorkbookX.Close SaveChanges:=False
End Sub
 
Vote positif 0 Vote négatif
Ok, code simplement adapté à ma sauce et testé !
VB: 
Option Explicit

'======================================================================================
'Requires the Reference "Microsoft for Visual Basic for Applications Exetnsibility 5.3"
'======================================================================================

Sub Test()
    Call CopyWorkbookToNewWorkbook(ThisWorkbook, IncludeVBAProject:=True)
End Sub

'------------------------------------
'Copy as Workbook into a new Workbook
'------------------------------------
Sub CopyWorkbookToNewWorkbook(Workbook As Workbook, Optional IncludeVBAProject As Boolean = False)
    Dim TabArray() As Long
    Dim VBComponents As VBComponents
    Dim VBComponent As VBComponent
    Dim VBComponentExtension As String
    Dim VBComponentFileName As String
    Dim VBComponentsCollection As New Collection
    Dim i As Integer
   
    '--------------------------------------------------------------------
    'Copy the Workbook & Worksheets with their VBA code to a new Workbook
    '--------------------------------------------------------------------
    With Workbook
        ReDim TabArray(1 To .Worksheets.Count)
       
        For i = 1 To .Worksheets.Count
            TabArray(i) = i
        Next i
       
        .Worksheets(TabArray).Select
    End With
   
    'Creates a new target Workbook with the selected source Workbook Worksheets
    Worksheets.Copy
   
    '------------------------------------------------------------
    'Include the VBA Project Modules, Class Modules and UserForms
    '------------------------------------------------------------
    If IncludeVBAProject Then
        Set VBComponents = Workbook.VBProject.VBComponents
       
        If Not VBComponents Is Nothing Then
       
            'Export VBComponents of the source Workbook
            For Each VBComponent In VBComponents
                Select Case VBComponent.Type
                    Case vbext_ct_StdModule
                        VBComponentExtension = ".bas"
                       
                    Case vbext_ct_ClassModule
                        VBComponentExtension = ".cls"
                       
                    Case vbext_ct_MSForm
                        VBComponentExtension = ".frm"
                       
                    Case Else
                        VBComponentExtension = ""
                End Select
               
                If Not Len(VBComponentExtension) = 0 Then
                    VBComponentFileName = Environ("TMP") & "\" & VBComponent.Name & VBComponentExtension
                   
                    If Not Len(Dir(VBComponentFileName)) = 0 Then
                        Kill VBComponentFileName
                    End If
                   
                    VBComponent.Export VBComponentFileName
                    VBComponentsCollection.Add VBComponentFileName
                End If
            Next VBComponent
          
            'Import VBComponents to the target new Workbook
            Do While VBComponentsCollection.Count > 0
                ActiveWorkbook.VBProject.VBComponents.Import VBComponentsCollection(1)
                Kill VBComponentsCollection(1)
                VBComponentsCollection.Remove 1
            Loop
        End If
    End If
   
    'Close the source Workbook
    Workbook.Close SaveChanges:=False
End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Bonjour,

Pour que la copie des VBComponents soit finalement opérationnelle, il faut aussi ré-introduire les References manquantes sinon le code ne fonctionnera pas sauf ajout manuel des References manquantes.

Pour que la copie des VBComponents fonctionne il faut aussi que la sécurité des macros soit ouverte.


Un autre truc très étrange, c'est qu'après la copie des feuilles, si on ne ferme pas le classeur source, il est dans un drôle d'état avec par exemple l'onglet Insertion où les icônes sont grisées. Bizarre ! Ça se corrige si on ferme le classeur manuellement SANS enregistrer sinon il reste dans cet état verrouillé.
 
Dernière édition:
Vote positif 0 Vote négatif

C'est le résultat de la Sélection de toutes les feuilles.
Pour réduire ce phénomène, il faut ré-activer le classeur source et sélectionner sa 1er feuille.
 
Vote positif 0 Vote négatif
Voila un code plus complet qui...
  1. corrige le verrouillage ci-dessus,

  2. vérifie l' "Accès approuvé au modèle d'objet du projet VBA",

  3. ajoute les References (en plus des VBComponents),

  4. ajoute les Shapes en adaptant le OnAction si besoin.
VB: 
Option Explicit

'======================================================================================
'Requires the Reference "Microsoft for Visual Basic for Applications Exetnsibility 5.3"
'======================================================================================

Sub Test()
    Call CopyWorkbookToNewWorkbook(ThisWorkbook, IncludeVBAProject:=True)
End Sub

'------------------------------------
'Copy as Workbook into a new Workbook
'------------------------------------
Sub CopyWorkbookToNewWorkbook(SourceWorkbook As Workbook, Optional IncludeVBAProject As Boolean = False)
    Dim TargetWorkbook As Workbook
    Dim TabArray() As Variant
    Dim VBComponents As VBComponents
    Dim VBComponent As VBComponent
    Dim VBComponentExtension As String
    Dim VBComponentFileName As String
    Dim VBComponentsCollection As New Collection
    Dim ErrNumber As Long
    Dim S As String
    Dim i As Integer
    Dim k As Integer
    Dim p As Integer
 
    Application.ScreenUpdating = False
 
    '----------------------------------------------------------------------------------
    'Copy the source Workbook & Worksheets with their VBA code to a new target Workbook
    '----------------------------------------------------------------------------------
    With SourceWorkbook
        ReDim TabArray(1 To .Worksheets.Count)
   
        For i = 1 To .Worksheets.Count
            TabArray(i) = i
        Next i
   
        'Creates a new target Workbook with the selected source Workbook Worksheets
        .Worksheets(TabArray).Select
        Worksheets.Copy
        Set TargetWorkbook = ActiveWorkbook

        'Needed to "unlock" the all Worksheets Selection   
        With SourceWorkbook
            .Activate
            .Worksheets(1).Select
        End With
   
        TargetWorkbook.Activate

        '---------------
        'Copy the Shapes
        '---------------
        For i = 1 To .Worksheets.Count
            For k = 1 To .Worksheets(i).Shapes.Count
                'Copy the Shape and its position
                .Worksheets(i).Shapes(k).Copy
                TargetWorkbook.Worksheets(i).Paste
                TargetWorkbook.Worksheets(i).Shapes(k).Left = .Worksheets(i).Shapes(k).Left
                TargetWorkbook.Worksheets(i).Shapes(k).Top = .Worksheets(i).Shapes(k).Top
           
                'Adapt the OnAction string
                S = .Worksheets(i).Shapes(k).OnAction
                If Not Len(S) = 0 Then
                    p = InStr(S, "!")
                    If p > 0 Then
                        If Replace(Left(S, p - 1), "'", "") = SourceWorkbook.Name Then
                            TargetWorkbook.Worksheets(i).Shapes(k).OnAction = "'" & TargetWorkbook.Name & "'!" & Mid(S, p + 1)
                        End If
                    End If
                End If
            Next k
       
            'Release the last Shape selected
            ActiveCell.Select
        Next i
    End With
 
    '------------------------------------------------------------
    'Include the VBA Project Modules, Class Modules and UserForms
    '------------------------------------------------------------
    If IncludeVBAProject Then
        If VBEOK Then
            Set VBComponents = SourceWorkbook.VBProject.VBComponents
       
            If Not VBComponents Is Nothing Then
                'Export VBComponents of the source Workbook
                For Each VBComponent In VBComponents
                    Select Case VBComponent.Type
                        Case vbext_ct_StdModule
                            VBComponentExtension = ".bas"
                       
                        Case vbext_ct_ClassModule
                            VBComponentExtension = ".cls"
                       
                        Case vbext_ct_MSForm
                            VBComponentExtension = ".frm"
                       
                        Case Else
                            VBComponentExtension = ""
                    End Select
               
                    If Not Len(VBComponentExtension) = 0 Then
                        VBComponentFileName = Environ("TMP") & "\" & VBComponent.Name & VBComponentExtension
                   
                        If Not Len(Dir(VBComponentFileName)) = 0 Then
                            Kill VBComponentFileName
                        End If
                   
                        VBComponent.Export VBComponentFileName
                        VBComponentsCollection.Add VBComponentFileName
                    End If
                Next VBComponent
         
                'Import VBComponents to the new target Workbook
                Do While VBComponentsCollection.Count > 0
                    TargetWorkbook.VBProject.VBComponents.Import VBComponentsCollection(1)
                    Kill VBComponentsCollection(1)
                    VBComponentsCollection.Remove 1
                Loop
           
                'Copy the Reference list of the source Workbook into the target new Workbook
                With SourceWorkbook
                    On Error Resume Next
                    For i = 1 To .VBProject.References.Count
                        TargetWorkbook.VBProject.References.AddFromFile .VBProject.References.Item(i).FullPath
                    Next i
                    On Error GoTo 0
                End With
            End If
        End If
    End If
 
    Application.ScreenUpdating = True
 
    'Close the source Workbook
    SourceWorkbook.Close SaveChanges:=False
End Sub

'-------------------------------------------------------------------------------------
'Return True if the "Trust Access to the VBA Project Object Model" checkbox is checked
'-------------------------------------------------------------------------------------
Function VBEOK() As Boolean
    Dim Version As String
    Dim ErrNumber As Long
 
    On Error Resume Next
    Version = ThisWorkbook.VBProject.VBE.Version
    ErrNumber = Err.Number
    On Error GoTo 0
 
    If ErrNumber = 0 Then
        'Return value
        VBEOK = True
    End If
End Function
 
Dernière édition:
Vote positif 0 Vote négatif
re
Bonjour @Dudu2
donc si pas vbeok tu copie pas les modules?
😉
autrement dit si ton intention est de copier classeur et module et que l'accès approuvé .... n'est pas coché tu es chocolat quoi ?))
met au moins un msgbox disant "désolé le niveau de sécurité interdit le déplacement ou même l'accès aux modules" ou un truc du genre
j'imagine mec répétant l’opération 5/10/20 fois 🤪🤣🤣🤣
mais punaise!!! c'est quoi ce truc ca marche pas !! je vais tout péter🤣🤣🤣🤣🤣🤣

drôle non?
LOL
 
Vote positif 0 Vote négatif
re
de plus perso je pense que ca doit être traité (pré copie) au cas ou justement l'intention est de copier avec les macros
inutile de copier si on veut les macros et qu'on ne les aura pas hein 😉

VB: 
Sub Test()
    Call CopyWorkbookToNewWorkbook(ThisWorkbook, IncludeVBAProject:=True)
End Sub

'------------------------------------
'Copy as Workbook into a new Workbook
'------------------------------------
Sub CopyWorkbookToNewWorkbook(SourceWorkbook As Workbook, Optional IncludeVBAProject As Boolean = False)
    Dim TargetWorkbook As Workbook
    Dim TabArray() As Variant
    Dim VBComponents As VBComponents
    Dim VBComponent As VBComponent
    Dim VBComponentExtension As String
    Dim VBComponentFileName As String
    Dim VBComponentsCollection As New Collection
    Dim ErrNumber As Long
    Dim S As String
    Dim i As Integer
    Dim k As Integer
    Dim p As Integer
    Dim Rep As VbMsgBoxResult
    Dim Rep2 As VbMsgBoxResult
   
    Application.ScreenUpdating = False
   
    On Error Resume Next
    If IncludeVBAProject Then
        Set VBComponents = SourceWorkbook.VBProject.VBComponents
        If Err Then
            Rep = MsgBox("En l'etat le niveau de sécurité dans les options d'Excel" & vbCrLf & _
                          "Ne permet pas la copie des modules" & vbCrLf & vbCrLf & _
                          "Vous devez cochez l'accès aprouvé à l'objet du modèle de projet vba" & vbCrLf & vbCrLf & _
                          "Voulez vous aller activer  cet accès approuvé " & vbCrLf & _
                          "Vous pourez réessayer après activation de cet accès ", vbYesNo + vbInformation)
           
            If Rep = vbYes Then
                Application.CommandBars.ExecuteMso "MacroSecurity"
            Exit Sub
            Else
                Rep2 = MsgBox("Très bien pas de modules exportés" & vbCrLf & _
                               "Voulez vous continuer la creation" & vbCrLf & "du clone de ce classeur Sans ces Macros !!!", vbYesNo, vbInformation)
                If Rep2 = vbNo Then Exit Sub
            End If
        End If
    End If
   
    '----------------------------------------------------------------------------------
    'Copy the source Workbook & Worksheets with their VBA code to a new target Workbook
    '----------------------------------------------------------------------------------
    With SourceWorkbook
        ReDim TabArray(1 To .Worksheets.Count)
       
        For i = 1 To .Worksheets.Count
            TabArray(i) = i
        Next i
       
        'Creates a new target Workbook with the selected source Workbook Worksheets
        .Worksheets(TabArray).Select
        Worksheets.Copy
        Set TargetWorkbook = ActiveWorkbook
       
        'Needed to "unlock" the all Worksheets Selection
        With SourceWorkbook
            .Activate
            .Worksheets(1).Select
        End With
       
        TargetWorkbook.Activate
       
        '---------------
        'Copy the Shapes
        '---------------
        For i = 1 To .Worksheets.Count
            For k = 1 To .Worksheets(i).Shapes.Count
                'Copy the Shape and its position
                .Worksheets(i).Shapes(k).Copy
                TargetWorkbook.Worksheets(i).Paste
                TargetWorkbook.Worksheets(i).Shapes(k).Left = .Worksheets(i).Shapes(k).Left
                TargetWorkbook.Worksheets(i).Shapes(k).Top = .Worksheets(i).Shapes(k).Top
               
                'Adapt the OnAction string
                S = .Worksheets(i).Shapes(k).OnAction
                If Not Len(S) = 0 Then
                    p = InStr(S, "!")
                    If p > 0 Then
                        If Replace(Left(S, p - 1), "'", "") = SourceWorkbook.Name Then
                            TargetWorkbook.Worksheets(i).Shapes(k).OnAction = "'" & TargetWorkbook.Name & "'!" & Mid(S, p + 1)
                        End If
                    End If
                End If
            Next k
           
            'Release the last Shape selected
            ActiveCell.Select
        Next i
    End With
   
    '------------------------------------------------------------
    'Include the VBA Project Modules, Class Modules and UserForms
    '------------------------------------------------------------
    If IncludeVBAProject Then
        If VBEOK Then
            Set VBComponents = SourceWorkbook.VBProject.VBComponents
           
            If Not VBComponents Is Nothing Then
                'Export VBComponents of the source Workbook
                For Each VBComponent In VBComponents
                    Select Case VBComponent.Type
                        Case vbext_ct_StdModule
                            VBComponentExtension = ".bas"
                           
                        Case vbext_ct_ClassModule
                            VBComponentExtension = ".cls"
                           
                        Case vbext_ct_MSForm
                            VBComponentExtension = ".frm"
                           
                        Case Else
                            VBComponentExtension = ""
                    End Select
                   
                    If Not Len(VBComponentExtension) = 0 Then
                        VBComponentFileName = Environ("TMP") & "\" & VBComponent.Name & VBComponentExtension
                       
                        If Not Len(Dir(VBComponentFileName)) = 0 Then
                            Kill VBComponentFileName
                        End If
                       
                        VBComponent.Export VBComponentFileName
                        VBComponentsCollection.Add VBComponentFileName
                    End If
                Next VBComponent
               
                'Import VBComponents to the new target Workbook
                Do While VBComponentsCollection.Count > 0
                    TargetWorkbook.VBProject.VBComponents.Import VBComponentsCollection(1)
                    Kill VBComponentsCollection(1)
                    VBComponentsCollection.Remove 1
                Loop
               
                'Copy the Reference list of the source Workbook into the target new Workbook
                With SourceWorkbook
                    On Error Resume Next
                    For i = 1 To .VBProject.References.Count
                        TargetWorkbook.VBProject.References.AddFromFile .VBProject.References.Item(i).FullPath
                    Next i
                    On Error GoTo 0
                End With
            End If
        End If
    End If
   
    Application.ScreenUpdating = True
   
    'Close the source Workbook
    SourceWorkbook.Close SaveChanges:=False
End Sub

'-------------------------------------------------------------------------------------
'Return True if the "Trust Access to the VBA Project Object Model" checkbox is checked
'-------------------------------------------------------------------------------------
Function VBEOK() As Boolean
    Dim Version As String
    Dim ErrNumber As Long
   
    On Error Resume Next
    Version = ThisWorkbook.VBProject.VBE.Version
    ErrNumber = Err.Number
    On Error GoTo 0
   
    If ErrNumber = 0 Then
        'Return value
        VBEOK = True
    End If
End Function
)
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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

POWERQUERY :: Combinaisons (Table.Combine) de dossiers contenant des fichiers .CSV ou des fichiers Excel - V2
Réponses
0
Affichages
849
oguruma
  • Question Question
VBA : supprimer un classeur à sa fermeture
2 3
Réponses
39
Affichages
15 K
XloneClick
X
S
  • Question Question
comment enregistré un seul feuille de mon fichier en XML et pas le classeur
Réponses
1
Affichages
2 K
saverloo
S
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…