[英]VBA to copy worksheet from one workbook to all workbooks in another folder
[英]Copy all VBA codes from workbook to another
我搜索了很多,發現了很多 VBA 代碼模塊的 VBA 代碼,但我需要的有點不同。 我有一個大型項目,在標准模塊、工作表模塊、ThisWorkbook 模塊中有很多 VBA 代碼。 所有這些都有 VBA 代碼,還有另一個工作簿說(“New.xlsm”),我需要將所有這些 VBA 代碼復制到它。 但在導出這些 VBA 代碼之前,我需要從任何模塊的任何代碼中清除“New.xlsm”,或者刪除任何現有模塊並清除所有內容..然后將 vba 代碼復制到“New.xlsm”。
我有這段代碼可以導出所有 VBE 組件,但這可能只是一個步驟。
Sub Export_All_VBE_Components()
'References: Microsoft Visual Basic for Applications Extensibility 5.3
'---------------------------------------------------------------------
Dim vbComp As VBIDE.VBComponent
Dim destDir As String
Dim fName As String
Dim ext As String
If ActiveWorkbook.Path = "" Then MsgBox "You Must First Save This Workbook Somewhere So That It Has A Path.", , "Error": Exit Sub
destDir = ActiveWorkbook.Path & "\" & ActiveWorkbook.name & " Modules"
If Dir(destDir, vbDirectory) = vbNullString Then MkDir destDir
For Each vbComp In ActiveWorkbook.VBProject.VBComponents
If vbComp.CodeModule.CountOfLines > 0 Then
Select Case vbComp.Type
Case vbext_ct_ClassModule: ext = ".cls"
Case vbext_ct_Document: ext = ".cls"
Case vbext_ct_StdModule: ext = ".bas"
Case vbext_ct_MSForm: ext = ".frm"
Case Else: ext = vbNullString
End Select
If ext <> vbNullString Then
fName = destDir & "\" & vbComp.name & ext
If Dir(fName, vbNormal) <> vbNullString Then Kill (fName)
vbComp.Export (fName)
End If
End If
Next vbComp
End Sub
我已經解決了從“original.xlm”中刪除所有現有代碼的第一步
Sub Test_RemoveAllMacros()
Application.ScreenUpdating = False
RemoveAllMacros Application.Workbooks("Original.xlsm")
Application.ScreenUpdating = True
End Sub
Sub RemoveAllMacros(wbk As Workbook)
Dim vbCode As Object, vbComp As Object, vbProj As Object
Set vbProj = wbk.VBProject
With vbProj
For Each vbComp In .VBComponents
Select Case vbComp.Type
Case 1, 2, 3
vbProj.VBComponents.Remove vbComp
Case 100
Set vbCode = vbComp.CodeModule
vbCode.DeleteLines 1, vbCode.CountOfLines
End Select
Next vbComp
End With
End Sub
我現在需要的是將所有宏從“New.xlm”復制到“Original.xlsm”
我找到了這段代碼,但這需要命名我需要復制的每個模塊。 我不需要指定任何模塊名稱,因為我有大約 30 個模塊和工作表模塊......還有 ThisWorkbook 模塊
Sub Copy_module()
Dim varModule, wbkSource As Workbook, wbkTarget As Workbook, strModule As String
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wbkSource = ThisWorkbook
Set wbkTarget = Application.Workbooks("Original.xlsm")
With wbkTarget.VBProject.VBComponents
For Each varModule In Array("Module1", "Module2")
strModule = ThisWorkbook.Path & "\" & varModule & ".bas"
wbkSource.VBProject.VBComponents(varModule).Export Filename:=strModule
On Error Resume Next
.Remove VBComponent:=.Item(varModule)
On Error GoTo 0
.Import Filename:=ThisWorkbook.Path & "\" & varModule & ".bas"
Kill strModule
Next varModule
End With
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
*** 要復制工作表模塊,我發現了這個
Sub CopyWorksheetsModules()
Dim src, dest, wb As Workbook, ws As Worksheet
On Error Resume Next
For Each ws In ThisWorkbook.Worksheets
Set src = ThisWorkbook.VBProject.VBComponents(ws.CodeName).CodeModule
Set wb = Workbooks("Original.xlsm")
Set dest = wb.VBProject.VBComponents(ws.CodeName).CodeModule
dest.DeleteLines 1, dest.CountOfLines
dest.AddFromString src.Lines(1, src.CountOfLines)
Next ws
On Error GoTo 0
End Sub
我沒有測試過這段代碼,但這是我發現的:
要將模塊從一個工作簿復制到另一個[credit] :
Sub CopyModule(SourceWB As Workbook, strModuleName As String, _
TargetWB As Workbook)
'
' example:
' CopyModule Workbooks("Book1.xls"), "Module1", _
Workbooks("Book2.xls")
Dim strFolder As String, strTempFile As String
strFolder = SourceWB.Path
If Len(strFolder) = 0 Then strFolder = CurDir
strFolder = strFolder & "\"
strTempFile = strFolder & "~tmpexport.bas"
On Error Resume Next
SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile
TargetWB.VBProject.VBComponents.Import strTempFile
Kill strTempFile
On Error GoTo 0
End Sub
要從工作簿中刪除所有代碼[credit] :
Sub DeleteAllCode()
'Trust Access To Visual Basics Project must be enabled.
'From Excel: Tools | Macro | Security | Trusted Sources
Dim x As Integer
On Error Resume Next
With Workbooks("Wb").VBProject
For x = .VBComponents.Count To 1 Step -1
.VBComponents.Remove .VBComponents(x)
Next x
For x = .VBComponents.Count To 1 Step -1
.VBComponents(x).CodeModule.DeleteLines _
1, .VBComponents(x).CodeModule.CountOfLines
Next x
End With
On Error GoTo 0
End Sub
希望有幫助。
這是我用來導入/導出模塊的代碼。 導出模塊將刪除保存它們的文件夾中的所有當前文件。 並且導入模塊將在導入之前刪除所有模塊。 請注意:
ElseIf Not VBComp.Name Like "*Modulos*" Then
VBProj.VBComponents.Remove VBComp
End If
是為了避免刪除處理導入/導出的模塊。 它們被稱為ImportarModulos
和ExportarModulos
,因此請使用關鍵字來識別它們並避免刪除和導入它們(因為它可能會給您帶來問題。)
導出模塊:
Option Explicit
Public Sub ExportModules()
Dim bExport As Boolean
Dim wkbSource As Excel.Workbook
Dim szSourceWorkbook As String
Dim szExportPath As String
Dim szFileName As String
Dim cmpComponent As VBIDE.VBComponent
''' The code modules will be exported in a folder named.
''' VBAProjectFiles in the Documents folder.
''' The code below create this folder if it not exist
''' or delete all files in the folder if it exist.
If FolderWithVBAProjectFiles = "Error" Then
MsgBox "Export Folder not exist"
Exit Sub
End If
On Error Resume Next
Kill FolderWithVBAProjectFiles & "\*.*"
On Error GoTo 0
''' NOTE: This workbook must be open in Excel.
szSourceWorkbook = ActiveWorkbook.Name
Set wkbSource = Application.Workbooks(szSourceWorkbook)
If wkbSource.VBProject.Protection = 1 Then
MsgBox "The VBA in this workbook is protected," & _
"not possible to export the code"
Exit Sub
End If
szExportPath = FolderWithVBAProjectFiles & "\"
For Each cmpComponent In wkbSource.VBProject.VBComponents
bExport = True
szFileName = cmpComponent.Name
''' Concatenate the correct filename for export.
Select Case cmpComponent.Type
Case vbext_ct_ClassModule
szFileName = szFileName & ".cls"
Case vbext_ct_MSForm
szFileName = szFileName & ".frm"
Case vbext_ct_StdModule
szFileName = szFileName & ".bas"
Case vbext_ct_Document
''' This is a worksheet or workbook object.
''' Don't try to export.
bExport = False
End Select
If bExport Then
''' Export the component to a text file.
cmpComponent.Export szExportPath & szFileName
''' remove it from the project if you want
'''wkbSource.VBProject.VBComponents.Remove cmpComponent
End If
Next cmpComponent
Dim wb As Workbook, ws As Worksheet, LastRow As Long
Set wb = Workbooks.Open("Z:\Planificacion-WFM\Planificacion Telefonica\Código\Log.xlsx")
Set ws = wb.Sheets(1)
LastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row + 1
ws.Cells(LastRow, 1) = Application.UserName
ws.Cells(LastRow, 2) = Format(Now(), "hh:mm:ss")
ws.Cells(LastRow, 3) = Format(Now(), "dd/mm/yyyy")
wb.Close Savechanges:=True
MsgBox "Export is ready"
End Sub
Function FolderWithVBAProjectFiles() As String
Dim WshShell As Object
Dim FSO As Object
Dim SpecialPath As String
Set WshShell = CreateObject("WScript.Shell")
Set FSO = CreateObject("scripting.filesystemobject")
SpecialPath = "Z:\Planificacion-WFM\Planificacion Telefonica\Código"
If Right(SpecialPath, 1) <> "\" Then
SpecialPath = SpecialPath & "\"
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = False Then
On Error Resume Next
MkDir SpecialPath & "VBAProjectFiles"
On Error GoTo 0
End If
If FSO.FolderExists(SpecialPath & "VBAProjectFiles") = True Then
FolderWithVBAProjectFiles = SpecialPath & "VBAProjectFiles"
Else
FolderWithVBAProjectFiles = "Error"
End If
End Function
導入模塊:
Option Explicit
Public Sub ImportModules()
Dim wkbTarget As Excel.Workbook
Dim objFSO As Scripting.FileSystemObject
Dim objFile As Scripting.File
Dim szTargetWorkbook As String
Dim szImportPath As String
Dim szFileName As String
Dim cmpComponents As VBIDE.VBComponents
'
' If ActiveWorkbook.Name = ThisWorkbook.Name Then
' MsgBox "Select another destination workbook" & _
' "Not possible to import in this workbook "
' Exit Sub
' End If
'Get the path to the folder with modules
If FolderWithVBAProjectFiles = "Error" Then
MsgBox "Import Folder not exist"
Exit Sub
End If
''' NOTE: This workbook must be open in Excel.
szTargetWorkbook = ActiveWorkbook.Name
Set wkbTarget = Application.Workbooks(szTargetWorkbook)
If wkbTarget.VBProject.Protection = 1 Then
MsgBox "The VBA in this workbook is protected," & _
"not possible to Import the code"
Exit Sub
End If
''' NOTE: Path where the code modules are located.
szImportPath = FolderWithVBAProjectFiles & "\"
Set objFSO = New Scripting.FileSystemObject
If objFSO.GetFolder(szImportPath).Files.Count = 0 Then
MsgBox "There are no files to import"
Exit Sub
End If
'Delete all modules/Userforms from the ActiveWorkbook
Call DeleteVBAModulesAndUserForms
Set cmpComponents = wkbTarget.VBProject.VBComponents
''' Import all the code modules in the specified path
''' to the ActiveWorkbook.
For Each objFile In objFSO.GetFolder(szImportPath).Files
If objFile.Name Like "*Modulos*" Then GoTo Siguiente
If (objFSO.GetExtensionName(objFile.Name) = "cls") Or _
(objFSO.GetExtensionName(objFile.Name) = "frm") Or _
(objFSO.GetExtensionName(objFile.Name) = "bas") Then
cmpComponents.Import objFile.Path
End If
Siguiente:
Next objFile
MsgBox "Módulos actualizados"
End Sub
Function DeleteVBAModulesAndUserForms()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Set VBProj = ActiveWorkbook.VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type = vbext_ct_Document Then
'Thisworkbook or worksheet module
'We do nothing
ElseIf Not VBComp.Name Like "*Modulos*" Then
VBProj.VBComponents.Remove VBComp
End If
Next VBComp
End Function
非常感謝 Damian 在這個主題上的巨大貢獻。 我非常感謝他的幫助。 這是我從不同資源收集的最終代碼,代碼將分兩步執行。 代碼將放在“New.xlsm”中,其中包含我需要復制的所有模塊(源工作簿),它將所有模塊(所有類型)復制到“original.xlsm”(目標工作簿)
'References: Microsoft Visual Basic for Applications Extensibility 5.3
'---------------------------------------------------------------------
Public destDir As String
Const destWorkbook As String = "Original.xlsm"
Sub P1_Export_All_VBE_Components()
Dim vbComp As VBIDE.VBComponent, fName As String, ext As String
If ThisWorkbook.Path = "" Then MsgBox "You Must First Save This Workbook Somewhere So That It Has A Path.", , "Error": Exit Sub
destDir = ThisWorkbook.Path & "\" & ThisWorkbook.Name & " Modules"
If Dir(destDir, vbDirectory) = vbNullString Then MkDir destDir
For Each vbComp In ThisWorkbook.VBProject.VBComponents
If vbComp.CodeModule.CountOfLines > 0 Then
Select Case vbComp.Type
Case vbext_ct_ClassModule: ext = ".cls"
Case vbext_ct_StdModule: ext = ".bas"
Case vbext_ct_MSForm: ext = ".frm"
Case Else: ext = vbNullString
End Select
If ext <> vbNullString Then
fName = destDir & "\" & vbComp.Name & ext
If Dir(fName, vbNormal) <> vbNullString Then Kill (fName)
vbComp.Export (fName)
End If
End If
Next vbComp
End Sub
Sub P2_Remove_Macros_Copy_All_Modules()
Dim src, dest, wbTarget As Workbook, ws As Worksheet, fso As Object, oFile As Object, sCode As String
Application.ScreenUpdating = False
Set wbTarget = Application.Workbooks(destWorkbook)
If wbTarget.VBProject.Protection = 1 Then MsgBox "The VBA In Target Workbook Is Protected", vbExclamation: Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.GetFolder(destDir).Files.Count = 0 Then MsgBox "There Are No Files To Export", vbExclamation: Exit Sub
RemoveAllMacros wbTarget
For Each oFile In fso.GetFolder(destDir).Files
If fso.GetExtensionName(oFile.Name) = "cls" Or fso.GetExtensionName(oFile.Name) = "bas" Or fso.GetExtensionName(oFile.Name) = "frm" Then
wbTarget.VBProject.VBComponents.Import oFile.Path
End If
Next oFile
On Error Resume Next
For Each ws In ThisWorkbook.Worksheets
Set src = ThisWorkbook.VBProject.VBComponents(ws.CodeName).CodeModule
Set dest = wbTarget.VBProject.VBComponents(ws.CodeName).CodeModule
dest.AddFromString src.Lines(1, src.CountOfLines)
Next ws
On Error GoTo 0
With ThisWorkbook.VBProject.VBComponents("ThisWorkbook").CodeModule
sCode = .Lines(1, .CountOfLines)
End With
wbTarget.VBProject.VBComponents("ThisWorkbook").CodeModule.AddFromString sCode
Application.ScreenUpdating = True
End Sub
Sub RemoveAllMacros(wbk As Workbook)
Dim vbCode As Object, vbComp As Object, vbProj As Object
Set vbProj = wbk.VBProject
With vbProj
For Each vbComp In .VBComponents
Select Case vbComp.Type
Case 1, 2, 3
vbProj.VBComponents.Remove vbComp
Case 100
Set vbCode = vbComp.CodeModule
vbCode.DeleteLines 1, vbCode.CountOfLines
End Select
Next vbComp
End With
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.