Este é um procedimento que escrevi há algum tempo para mover o máximo de VBA possível para outra pasta de trabalho no caso de ela se corromper - sinta-se à vontade para ajustar isso como achar melhor.
Nota importante : Para que isso funcione, você precisa ter acesso habilitado ao VBProject nas configurações de segurança. Você também precisa ter a pasta de trabalho que você está copiando de fechado.
MAIS Nota importante : Este código criará um diretório temporário e o excluirá quando terminar - verifique todos os caminhos e nomes no código para garantir que, por alguma coincidência, isso não seja uma pasta existente no seu sistema. Eu não sou responsável por nenhum arquivo / dados perdidos no seu sistema como resultado da execução deste código sem verificar corretamente.
Sub CopyBrokenWorkbook()
'// This sub will create a duplicate workbook with the prefix "EXP_"
'// and import all userforms & code modules from old workbook.
'
'// This sub requires access to the VBA Project Object Model, this option can
'// be found in the trust center settings under "Macro Settings".
Dim oldWB As Workbook, newWB As Workbook
Dim VBc As Variant
Dim exportFolder As String, VBcExt As String, Bill As String, _
newWBPath As String, testFile As String, wbPass As String
Dim i As Integer
'//Set old workbook
testFile = Application.GetOpenFilename("Excel Files (*.xl*), *.xl*")
If LCase(testFile) = "false" Then Exit Sub
If MsgBox("Is this workbook password protected?", vbYesNo) = vbYes Then _
wbPass = InputBox("Please enter workbook password:")
On Error Resume Next
Set oldWB = Workbooks.Open(testFile, Password:=wbPass)
If Err.Number = 1004 Then
MsgBox "Incorrect workbook password, this macro will now stop.", vbExclamation + vbOKOnly, "Error"
Err.Clear
Set oldWB = Nothing
Exit Sub
End If
On Error Goto 0
If oldWB.Name = ThisWorkbook.Name Then
MsgBox "Cannot run sub on this workbook!", vbCritical + vbOKOnly, "Error"
Exit Sub
End If
'//Check VBA protection
On Error Resume Next
If oldWB.VBProject.Protection <> 0 Then
If Err.Number = 1004 Then
Err.Clear
MsgBox "VBA Project Object Model is protected in " & oldWB.Name & vbCrLf _
& vbCrLf & "Please remove this protection in Trust Centre to continue.", _
vbExclamation + vbOKOnly, "Error"
oldWB.Close
Set oldWB = Nothing
Set newWB = Nothing
Exit Sub
Else
MsgBox Err.Number & ": " & Err.Description, vbExclamation, "Error"
oldWB.Close
Set oldWB = Nothing
Set newWB = Nothing
Err.Clear
Exit Sub
End If
End If
On Error Goto 0
Set newWB = Workbooks.Add
'//path to export folder
exportFolder = oldWB.Path & "\ExportTest"
'//if export folder exists, remove all files, otherwise creaate the folder
If CreateObject("Scripting.FileSystemObject").FolderExists(exportFolder) = True Then
On Error Resume Next
Kill exportFolder & "\*.*"
Err.Clear
On Error Goto 0
Else
MkDir exportFolder
End If
'//export all modules/class modules/userforms to folder
For Each VBc In oldWB.VBProject.VBComponents
Select Case VBc.Type
Case 1
VBcExt = ".bas"
Case 2
VBcExt = ".cls"
Case 3
VBcExt = ".frm"
Case 100
VBcExt = "SKIP"
End Select
If Not VBcExt = "SKIP" Then VBc.Export exportFolder & "\" & VBc.Name & VBcExt
Next VBc
'//duplicate sheet count in new workbook
Application.DisplayAlerts = False
Select Case oldWB.Sheets.Count
Case Is < 3
While newWB.Sheets.Count <> oldWB.Sheets.Count
newWB.Sheets(newWB.Sheets.Count).Delete
Wend
Case Is > 3
While newWB.Sheets.Count <> oldWB.Sheets.Count
newWB.Sheets.Add after:=newWB.Sheets.Count
Wend
End Select
Application.DisplayAlerts = True
'//duplicate sheet names in new workbook
For i = 1 To Sheets.Count
newWB.Sheets(i).Name = oldWB.Sheets(i).Name
Next i
'//save new workbook with old workbook's attributes and "EXP_" prefix
With oldWB
newWBPath = exportFolder & "\EXP_" & .Name
newWB.SaveAs newWBPath, .FileFormat
End With
'//import modules/class modules/userforms to new workbook
For Each VBc In CreateObject("Scripting.FileSystemObject").GetFolder(exportFolder).Files
Select Case LCase(Right(VBc.Name, 4))
Case ".bas", ".frm", ".cls"
newWB.VBProject.VBComponents.Import exportFolder & "\" & VBc.Name
End Select
Next VBc
'//save new workbook
newWB.Save
'//get pathname of old workbook for later
Bill = oldWB.Path & "\" & oldWB.Name
'//close workbooks
oldWB.Close False
newWB.Close False
'//release from memory
Set oldWB = Nothing
Set newWB = Nothing
'//create an excuse to reference a cool film whilst removing old workbook
'// Kill Bill <~~ ONLY UNCOMMENT THIS LINE IF YOU WANT TO DELETE ORIGINAL WORKBOOK!
'//move new workbook to old workbook directory
CreateObject("Scripting.FileSystemObject").GetFile(newWBPath).Move _
Mid(Bill, 1, InStrRev(Bill, "\"))
On Error Resume Next
Kill exportFolder & "\*.*"
On Error Goto 0
RmDir exportFolder
MsgBox "Transfer complete, please re-apply any password protection to your new workbook.", _
vbInformation, "Done"
End Sub