Copy工作及其代码到另一个工作簿

Posted 2023-02-05

我想从一个工作簿复制Excel工作表到另一个与它的所有VBA代码的。每次我试图“移动或复制工作表”的表复印件，但没有VBA模块转移到新的工作簿。有没有办法做到这一点？

答案

我用这样的事情过去。你的旅费可能会改变。它需要进行调整，以指的是两个不同的工作簿。它没有经过测试最近的MSOffice。我不知道，如果它在一个表对象处理代码。

Option Explicit
    Dim sExportLocation As String
    sExportLocation = "C:\myTempExport\" 'Do not forget the closing back slash! ie: C:\Temp\

Public Sub DoExportImport
    ExportTheModules
    ImportDatabaseObjects
End Sub    

Public Sub ExportTheModules
     '===============================================================================
     ' Name:    DocDatabase Purpose: Documents the database to a series of text files
     ' Author:  Arvin Meyer       ' Date:    June 02, 1999
     ' Comment: Uses the undocumented [Application.SaveAsText] syntax
     '          To reload use the syntax [Application.LoadFromText]
     '      Modified to set a reference to DAO 8/22/2005
     '===============================================================================
    Dim dbs As DAO.Database,  cnt As DAO.Container,  doc As DAO.Document

    Set cnt = dbs.Containers("Modules")
    For Each doc In cnt.Documents
        Application.SaveAsText acModule, doc.Name, sExportLocation & "Mods_" & doc.Name & ".txt"
    Next doc
End Sub

Public Sub ImportDatabaseObjects()
    On Error GoTo Err_ImportDatabaseObjects
    Dim db As Database      'Dim db As DAO.Database
    Dim td As TableDef, d As Document, c As Container  
    Set db = CurrentDb()

    Dim sFN As String, sName As String, sList() As Variant
    sList = Array("Module_", acModule)     ' Array("Module_", acModule, "Form_", acForm, "Query_", acQuery)
    sFN = Dir(sExportLocation & sList(0) & "*.txt")
    Do While sFN <> ""
        sName = Replace(sFN, sList(0), "")
        sName = Replace(sName, ".txt", "")
        Debug.Print sFN, , sName
        Application.LoadFromText sList(1), sName, sExportLocation & sFN
        sFN = Dir
    Loop

    Exit Sub

Err_ImportDatabaseObjects:
    MsgBox Err.Number & " - " & Err.Description
    Set c = Nothing
    db.Close
    Set db = Nothing    
End Sub