Export Module Using Macro - module

I'm stepping through the code to export a module using this post, but nothing happens. Is there a security setting to allow VBA permission to export a module?
I'm copying a few tabs from a workbook into a new workbook, but the tabs have macros which lead to broken links. To get around this I want to move the module and re-associate the macro. If I can't get this to work I will just copy the whole workbook and delete the info I don't want in the destination.
Here's the code from the above post:
Public Sub CopyModule(SourceWB As Workbook, strModuleName As String, TargetWB As Workbook)
' Description: copies a module from one workbook to another
' example: CopyModule Workbooks(ThisWorkbook), "Module2",
' Workbooks("Food Specials Rolling Depot Memo 46 - 01.xlsm")
' Notes: If Module to be copied already exists, it is removed first,
' and afterwards copied
Dim strFolder As String
Dim strTempFile As String
Dim FName As String
If Trim(strModuleName) = vbNullString Then
Exit Sub
End If
If TargetWB Is Nothing Then
MsgBox "Error: Target Workbook " & TargetWB.Name & " doesn't exist (or closed)", vbCritical
Exit Sub
End If
strFolder = SourceWB.Path
If Len(strFolder) = 0 Then strFolder = CurDir
' create temp file and copy "Module2" into it
strFolder = strFolder & "\"
strTempFile = strFolder & "~tmpexport.bas"
On Error Resume Next
FName = Environ("Temp") & "\" & strModuleName & ".bas"
If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
Err.Clear
Kill FName
If Err.Number <> 0 Then
MsgBox "Error copying module " & strModuleName & " from Workbook " & SourceWB.Name & " to Workbook " & TargetWB.Name, vbInformation
Exit Sub
End If
End If
' remove "Module2" if already exits in destination workbook
With TargetWB.VBProject.VBComponents
.Remove .Item(strModuleName)
End With
' copy "Module2" from temp file to destination workbook
SourceWB.VBProject.VBComponents(strModuleName).Export strTempFile
TargetWB.VBProject.VBComponents.Import strTempFile
Kill strTempFile
On Error GoTo 0
End Sub

Related

Create copy of .xlsm as .xlsx on save

I am trying to create backup copy of workbook .xlsm and save it as .xlsx
due to the same issue as here: Run time error '1004': Copy method of worksheet class failed - Temp file issue
I cannot use SaveCopyAs along with changing format of file
My workaround was to
create new copy of .xlsm file
open this new copy
save it as .xlsx
Close .xlsx file
Remove file from step 1
this is my code
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
On Error GoTo ErrorHandler:
'define variables
Dim backupfolder As String
Dim strFileName As String
Dim xlsxStrFileName As String
Dim fullPath As String
Dim xlsxFullPath As String
Dim wkb As Workbook
'get timestamp
dt = Format(CStr(Now), "yyyymmdd_hhmmss")
'construct full path to backup file which will be later converted to .xlsx
backupfolder = "c:\work\excel macro\delete\"
strFileName = "Test_iz_" & dt & ".xlsm"
fullPath = "" & backupfolder & strFileName
xlsxStrFileName = "Test_iz_" & dt & ".xlsx"
xlsxFullPath = "" & backupfolder & xlsxStrFileName
ActiveWorkbook.SaveCopyAs Filename:=fullPath
Set wkb = Workbooks.Open(fullPath)
wkb.Activate
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=xlsxFullPath, FileFormat:=51 'saves the file
Application.DisplayAlerts = True
'Application.Wait (Now + TimeValue("00:00:03"))
ActiveWorkbook.Close
Kill fullPath
Exit Sub
ErrorHandler:
MsgBox "An error occured " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description
MsgBox "Backup saved: " & xlsxFullPath
ActiveWorkbook.SaveAs Filename:=fullPath
End Sub
My problem is that i always end up in ErrorHandler, even though i got expected result
When i comment out line 2
On Error GoTo ErrorHandler:
error Run-time error '91': Object variable or With block variable not set
on Debug, it points to row with the code
wkb.Activate
and .xlsm file is not deleted
I guess the problem is that when i create new copy of xlsm file and save it, this entire code would be executed one more time and that issue is there somewhere, but i cannot find it.
Thank you
This worked on my computer:
Sub Workbook_BeforeSave()
On Error GoTo ErrorHandler:
'define variables
Dim backupfolder As String
Dim strFileName As String
Dim xlsxStrFileName As String
Dim fullPath As String
Dim xlsxFullPath As String
Dim wkb As Workbook
'get timestamp
dt = Format(CStr(Now), "yyyymmdd_hhmmss")
'construct full path to backup file which will be later converted to .xlsx
backupfolder = "c:\work\excel macro\delete\"
strFileName = "Test_iz_" & dt & ".xlsm"
fullPath = "" & backupfolder & strFileName
xlsxStrFileName = "Test_iz_" & dt & ".xlsx"
xlsxFullPath = "" & backupfolder & xlsxStrFileName
ActiveWorkbook.SaveAs Filename:=fullPath, FileFormat:=52
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=xlsxFullPath, FileFormat:=51 'saves the file
Application.DisplayAlerts = True
ActiveWorkbook.Close
Kill fullPath
Exit Sub
ErrorHandler:
MsgBox "An error occured " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description
MsgBox "Backup saved: " & xlsxFullPath
ActiveWorkbook.SaveAs Filename:=fullPath
End Sub
Cheers,
Jonathan

VBA Excel - Send to Compressed Zip Folder

I'm looking for a code to zip the folders of a path specified in my cells(1,1).value
After googling i found vba codes to zip the files of a folder but they are using WinZip.
My office machine does not have a WinZip installed and we are restricted to use WinZip. Could anyone please help with this. I need to use the default zip (Right click -> Send to compressed ZIP folder)
Thanks!
Sub Zip_File_Or_Files()
Dim strDate As String, DefPath As String, sFName As String
Dim oApp As Object, iCtr As Long, I As Integer
Dim FName, vArr, FileNameZip
DefPath = Application.DefaultFilePath
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"
'Browse to the file(s), use the Ctrl key to select more files
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True, Title:="Select the files you want to zip")
If IsArray(FName) = False Then
'do nothing
Else
'Create empty Zip File
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
I = 0
For iCtr = LBound(FName) To UBound(FName)
vArr = Split97(FName(iCtr), "\")
sFName = vArr(UBound(vArr))
If bIsBookOpen(sFName) Then
MsgBox "You can't zip a file that is open!" & vbLf & _
"Please close it and try again: " & FName(iCtr)
Else
'Copy the file to the compressed folder
I = I + 1
oApp.Namespace(FileNameZip).CopyHere FName(iCtr)
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = I
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
End If
Next iCtr
MsgBox "You find the zipfile here: " & FileNameZip
End If
End Sub
Powered by Ron De Bruin - http://www.rondebruin.nl/win/s7/win001.htm
I have found it helpful to make a couple of tweaks to make this more friendly for the user (which for this sort of thing is often myself).
Limit how long you're willing to wait for the file & message the user if that time limit was reached without success
Add a DoEvents so that you can ctrl+break to pause the code in case you want to inspect (otherwise - can sometimes have to crash Excel, in my experience)
Add a statusbar update so the user knows what's going on
Sub ZipTheFile(ByVal strPath As String, ByVal strFileNameXls As String, ByVal strFileNameZip As String)
'Taken largely from Ron De Bruin - https://www.rondebruin.nl/win/s7/win001.htm
'Create empty Zip File
NewZip (strPath & strFileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(strPath & strFileNameZip).CopyHere strPath & strFileNameXls
'Keep script waiting until Compressing is done (OR we waited more than 40 seconds...)
On Error Resume Next
i = 0
Do Until oApp.Namespace(strPath & strFileNameZip).Items.Count = 1 Or i > 40 '<-- set how long you're willing to wait here
Application.Wait (Now + TimeValue("0:00:01"))
DoEvents
Application.StatusBar = "Waiting for Zip - counter: " & i
i = i + 1
Loop
On Error GoTo 0
If i > 40 Then MsgBox "there seems to have been a problem putting the file into the zip foder. Check the zip at: " & strPath & strFileNameZip
End Sub
Sub NewZip(sPath) 'You need this sub-routine as well
'Create empty Zip File
'by Ron De Bruin - https://www.rondebruin.nl/win/s7/win001.htm
'Changed by keepITcool Dec-12-2005
If Len(Dir(sPath)) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
STILL Powered by Ron De Bruin - http://www.rondebruin.nl/win/s7/win001.htm

VBA Excel execute macro in all subfolders, not only particular folders

I am having problems with my code since it only works in the specific folders but not in all subfolders inside the particular folder.
Could someone please helps to make the code works to all subfolders inside that specific folder? :)
These are my code:
Sub Execute1()
Dim monthstr As String
Dim year As String
Dim monthtext As String
Dim prevmonth As String
Dim prevmonthtext As String
year = Range("D8").Text
monthstr = Trim(Range("D9").Text)
monthtext = Trim(Range("D10").Text)
prevmonth = Trim(Range("D11").Text)
prevmonthtext = Trim(Range("D12").Text)
prevyear = Trim(Range("D13").Text)
'confirmation box before running macro//////////////////////////////////////////////////////////////////////////////////////
response = MsgBox("Are you sure the settings are correct?", vbYesNo, "Confirmation")
If response = vbNo Then
Exit Sub
End If
'optimize macro speed///////////////////////////////////////////////////////////////////////////////////////////////////////////
Call Optimize
'finding the correct path (month)//////////////////////////////////////////////////////////////////////////////////////////
Dim myfile As String
Dim mypath As String
Dim newpath As String
mypath = "C:\Users\praseirw\Desktop\Tes CC\" & prevyear & "\SC\" & prevmonth & " " & prevmonthtext & "\"
myfile = Dir(mypath & "*.xlsx")
newpath = "C:\Users\praseirw\Desktop\Tes CC\" & year & "\SC\" & monthstr & " " & monthtext & "\"
'loop through all files in specified month//////////////////////////////////////////////////////////////////////////////////
Dim root As Workbook
Dim rng As Range
Dim wb As Workbook
Dim ws As Worksheet
Set root = Workbooks("CC Reports Center.xlsm")
Set rng = root.Worksheets("Settings").Range("H7:H14")
Do While myfile <> ""
Set wb = Workbooks.Open(mypath & myfile)
For Each ws In wb.Worksheets
rng.Copy
With ws.Range("D1")
.PasteSpecial xlPasteFormulas
End With
Next ws
Dim oldname As String
Dim newname As String
Dim wbname As String
oldname = wb.Name
wbname = Mid(oldname, 9)
newname = year & "_" & monthstr & "_" & wbname
wb.SaveAs Filename:=newpath & newname
wb.Close
Set wb = Nothing
myfile = Dir
Loop
Application.CutCopyMode = False
MsgBox "Task Complete!"
'reset macro optimization settings//////////////////////////////////////////////////////////////////////////////////////////////
Call ResetOptimize
End Sub
Here's one way to do it with the Dir function. If you want something a little more elegant you may want to consider using a FileSystemObject. (Note that to view Debug.Print output you have to enable the immediate window from under view.)
Sub test()
Dim root As String
root = "C:\"
Dim DC As New Collection
s = Dir(root & "*", vbDirectory)
Do Until s = ""
DC.Add s
s = Dir
Loop
For Each D In DC
Debug.Print D
On Error Resume Next: s = Dir(root & D & "\*.xl*"): On Error GoTo 0
Do Until s = ""
Debug.Print " " & s
s = Dir
Loop
Next
End Sub
Here's an example of how to do this with a FileSystemObject. Note that my code is a little sloppy with "On error resume next" to protect against access denied or other errors. Realistically you may want to consider incorporating better error handling, but that's another topic. Using a FileSystemObject is more powerful than Dir because Dir only returns a string, while FileSystemObject lets you work with files and folders as actual objects, which are much more powerful.
Sub test()
'You can use "CreateObject..." to add a FileSystemObject from the Scipting Library
'Alternatively, you can add a reference to "Microsoft Scripting Runtime"
'allowing you to directly declare a filesystemobject and access related intellisense
Set fso = CreateObject("Scripting.FileSystemObject")
Set Folder = fso.GetFolder("C:\")
For Each SubFolder In Folder.SubFolders
Debug.Print SubFolder.Name
On Error Resume Next
For Each File In SubFolder.Files
Debug.Print " " & File.Name
Next
On Error GoTo 0
Next
End Sub

VBA to save worksheet with a specific name

Hi probably a simple answer but im new to VBA.
I have a worksheet in a workbook. This worksheet has a specific reference in cell A1 which changes each time its used. It is basically an order number and formatted 03 01 15. The next will be 03 02 15, then 03 03 15 and so on.
What I want to do is to use VBA to save the sheet in a new workbook in my orders folder, and for the new workbook to be called the order number.
I can use the record macro function to get the basic VBA to copy the sheet, open a new workbook, paste the values and close the workbook, but im struggling with getting the name right. Each new workbook will have a different name based on the order number.
Any help would be appriciated.
Export a Worksheet to a Folder
Sub ExportWorksheetToFolder()
Const ProcTitle As String = "Export Worksheet to Folder"
' Define constants.
Const DESTINATION_SUBFOLDER_NAME As String = "Orders"
Const DESTINATION_FILE_NAME_ADDRESS As String = "A1"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = ActiveSheet
' Instead, improve with e.g.
'Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
' Build the destination file path ('dFilePath').
' Since we will be saving an unsaved workbook (file), by not supplying
' the file extension and the parameter for the FileFormat argument
' of the SaveAs method, the new workbook will be saved
' with the .xlsx extension (losing any code in it) or,
' for Office prior to version 2007, with the .xls extension.
Dim pSep As String: pSep = Application.PathSeparator
' If the cell is blank, we don't have a name.
Dim dBaseName As String
dBaseName = CStr(ws.Range(DESTINATION_FILE_NAME_ADDRESS))
If Len(dBaseName) = 0 Then
MsgBox "Cell " & UCase(DESTINATION_FILE_NAME_ADDRESS) & " is blank.", _
vbCritical, ProcTitle
Exit Sub
End If
' If the workbook has never been saved, its path is "".
Dim wbPath As String: wbPath = ws.Parent.Path
If Len(wbPath) = 0 Then
MsgBox "You need to save the workbook to use this procedure.", _
vbCritical, ProcTitle
Exit Sub
End If
' Create the subfolder if it doesn't exist.
Dim dFolderPath As String: dFolderPath = wb.Path _
& pSep & DESTINATION_SUBFOLDER_NAME & pSep
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then MkDir dFolderPath
Dim dFilePath As String: dFilePath = dFolderPath & dBaseName
' Copy.
ws.Copy ' copies the worksheet to a new workbook
' Save.
Dim MsgString As String
With Workbooks(Workbooks.Count) ' reference the new workbook
Application.DisplayAlerts = False
' 1. save without macros ... without confirmation
' 2. overwrite existing file ... without confirmation
On Error Resume Next
.SaveAs dFilePath
If Err.Number <> 0 Then ' invalid file name, file open...
MsgString = "Run-time error '" & Err.Number & "':" _
& vbLf & vbLf & Err.Description _
& vbLf & vbLf & "Could not save as '" & dFilePath & "'."
End If
On Error GoTo 0
Application.DisplayAlerts = True
.Close SaveChanges:=False
End With
' Inform.
If Len(MsgString) = 0 Then
MsgBox "Worksheet exported.", vbInformation, ProcTitle
Else
MsgBox MsgString, vbCritical, ProcTitle
End If
End Sub

Excel VBA Open a Folder

Using 2010 Excel VBA - I'm just trying to open a folder through a sub. What am I doing wrong here?
VBA
Sub openFolder()
Dim preFolder As String, theFolder As String, fullPath as String
theFolder = Left(Range("T12").Value, 8)
preFolder = Left(Range("T12").Value, 5) & "xxx"
fullPath = "P:\Engineering\031 Electronic Job Folders\" & preFolder & "\" & theFolder
Shell(theFolder, "P:\Engineering\031 Electronic Job Folders\" & preFolder, vbNormalFocus)
End Sub
If you want to open a windows file explorer, you should call explorer.exe
Call Shell("explorer.exe" & " " & "P:\Engineering", vbNormalFocus)
Equivalent syxntax
Shell "explorer.exe" & " " & "P:\Engineering", vbNormalFocus
I use this to open a workbook and then copy that workbook's data to the template.
Private Sub CommandButton24_Click()
Set Template = ActiveWorkbook
With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = "I:\Group - Finance" ' Yu can select any folder you want
.Filters.Clear
.Title = "Your Title"
If Not .Show Then
MsgBox "No file selected.": Exit Sub
End If
Workbooks.OpenText .SelectedItems(1)
'The below is to copy the file into a new sheet in the workbook and paste those values in sheet 1
Set myfile = ActiveWorkbook
ActiveWorkbook.Sheets(1).Copy after:=ThisWorkbook.Sheets(1)
myfile.Close
Template.Activate
ActiveSheet.Cells.Select
Selection.Copy
Sheets("Sheet1").Select
Cells.Select
ActiveSheet.Paste
End With