Suppose I want a create a new excel workbook(blank) using macros and the user should be prompted to enter the file name and location, the new file should not overwrite some existing file with the same name that user has entered
The name of file that user has entered should be saved in some cell of the existing sheet in which I am running the macros
Till now I have been using this
Workbooks.Add
Dim file_name As Variant
ActiveWorkbook.file_name = _
Application.GetSaveAsFilename(FileFilter:="Microsoft Excel file (*.xls), *.xls")
I don't know how to copy the name to the cell
I am getting error message: Run-time error'438' with the above code
I don't know how to fix it, I am a beginner, some help please
Option Explicit
Public Function wbNewWB(rngCelltoWriteTheFilenameTo As Range) As Workbook
Dim wbNew As Workbook
Dim vFilename As Variant
Dim bFileexists As Boolean
Set wbNew = Workbooks.Add
bFileexists = True
Do
vFilename = Application.GetSaveAsFilename(fileFilter:="Microsoft Excel file (*.xls), *.xls")
bFileexists = Dir(vFilename) <> ""
Loop Until vFilename <> False And bFileexists = False
wbNew.SaveAs Filename:=vFilename
rngCelltoWriteTheFilenameTo.Value = vFilename
Set wbNewWB = wbNew
End Function
Sub test()
Dim wbMyWB
Set wbMyWB = wbNewWB(ThisWorkbook.Worksheets(1).Range("A1"))
Debug.Print "Finished"
End Sub
As far as I understood your requirements correctly, this might be a solution: the function wbNewWB adds a new workbook, then asks for a file name and checks whether a file with this file name already exists. If a filename is provided and does not already exist, the workbook is saved under the provided file name and the file name is stored as a value in the cell you determine as an input parameter to the function. Finally the new workbook is provided as the return value of the function.
To illustrate the usage of the function I further added a sub, where the function is called.
To use this code, you should simply add a module to your existing project and copy & paste the code.
Related
I looked here and tried many solutions but could not get my code run as expected.
I have one macro enabled workbook with one module on a sheet named "Original"
I created have a second sheet as master where a add a button to copy the the "original" sheet and save the copy as macro enabled.
When I open the copied file the macro still refer to the initial file. I want the macro be just in the copied file because I cannot distribute the source file to the users.
Following is my code
==>How i copy the file
Sub createNew(fineName As String)
Dim mybook As Workbook
Set mybook = ThisWorkbook
Set newBook = Workbooks.Add
mybook.Sheets("Original").Copy Before:=newBook.Sheets(1)
Set newWs = newBook.Sheets("Original")
newWs.Name = Left(fineName, 30)
End Sub
==>How I save the file
Sub savefile(fname As String, compid As Long)
fname = "PS_" & fname
Set newBook = ActiveWorkbook
Application.DisplayAlerts = False
newBook.SaveAs fname, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Application.DisplayAlerts = True
closefile newBook
End Sub
I will appreciate your help!
Thank you all. I could solve the problem. Thanks to your comments I realized I had I had to copy the module to the newly copied file
Sub CopyOneModule()
Dim FName As String
With Workbooks("Book2")
*** FName = .Path & "\code.txt"
*** .VBProject.VBComponents("Module1").Export FName
End With
Workbooks("book1").VBProject.VBComponents.Import FName
End Sub
I have some VBA script in one Excel Workbook that has three subs that each either read from a second Workbook. Each of the subs uses the following algorithm (simplified to distill the interaction with the second book):
Public Sub EditRemote()
Dim remoteDataSheet As Worksheet
Dim source As String 'Source worksheet name
Dim target As String 'Target worksheet name
Dim path As String
Dim wkbName As String
source = "CountData"
path = ThisWorkbook.Worksheets("Parameters").Range("B2").Value
wkbName = ThisWorkbook.Worksheets("Parameters").Range("A2").Value
target = "CountData"
Application.EnableCancelKey = xlDisabled
Set localDataSheet = ThisWorkbook.Sheets(source)
If Not WorkbookIsOpen(wkbName) Then
Workbooks.Open (path)
End If
Set remoteDataSheet = Workbooks(wkbName).Sheets(source)
remoteDataSheet.Cells(1,1) = localDataSheet.Cells(1,1)
remoteDataSheet.Cells(1,2) = localDataSheet.Cells(1,2)
Workbooks(wkbName).Close SaveChanges:=True
End Sub
Function WorkbookIsOpen(targetWorkbook As String) As Boolean
Dim testBook As Workbook
On Error Resume Next
Set testBook = Workbooks(targetWorkbook)
If Err.Number = 0 Then
WorkbookIsOpen = True
Else:
WorkbookIsOpen = False
End If
End Function
There is also a pivot table in this Workbook that draws its data from the second file though an external data connection as well. The issue that is plaguing me is that it seems that not initially but after a few operations, these subs stop making the edits properly and instead it opens a read only copy of the second Workbook. When I try to open the second workbook manually I get a message saying that the file is already open and is locked for editing. Right now both files are local to my computer and couldn't be opened by anyone else. What am I missing to be sure that I can make the code work as intended?
I made some modification to your code, ran it a few times, and didn't get your "Read-only" message.
In your code the line of declaring localDataSheet is missing, added Dim localDataSheet As Worksheet , also added Dim remoteWb As Workbook for the remote workbook.
(didn't modify your Funtion WorkbookIsOpen code).
Sub EditRemote Code
Option Explicit
Public Sub EditRemote()
Dim remoteDataSheet As Worksheet
Dim localDataSheet As Worksheet
Dim source As String 'Source worksheet name
Dim target As String 'Target worksheet name
Dim path As String
Dim wkbName As String
Dim remoteWb As Workbook
source = "CountData"
path = ThisWorkbook.Worksheets("Parameters").Range("B2").Value
wkbName = ThisWorkbook.Worksheets("Parameters").Range("A2").Value
target = "CountData"
Application.EnableCancelKey = xlDisabled
Set localDataSheet = ThisWorkbook.Sheets(source)
' check if workbbok already open
If Not WorkbookIsOpen(wkbName) Then
Set remoteWb = Workbooks.Open(path)
Else
Set remoteWb = Workbooks(wkbName) ' workbook is open >> set remoteWb accordingly
End If
Set remoteDataSheet = remoteWb.Sheets(source)
remoteDataSheet.Cells(1, 1) = localDataSheet.Cells(1, 1)
remoteDataSheet.Cells(1, 2) = localDataSheet.Cells(1, 2)
Workbooks(wkbName).Close SaveChanges:=True
End Sub
Just to verify the data in your Excel "Parameters" sheet, the screen-shot below shows the data I used for my testing.
Cell A2 contains the "Clean" workbook name.
Cell B2 contains workbbok "full" name - path + "clean" workbook name.
After some further testing to diagnose the issue, I found that there was nothing wrong with the VBA code, but rather the external data connection to the remote Workbook was locking that Workbook every time I refreshed the data in the pivot table that used the external data connection as its source. It isn't unlocking the file when it is done refreshing, and that leaves the file locked until I close the Workbook with the pivot table. Now I just need to solve that problem.
I am trying to copy a module from one excel workbook to another using VBA.
My Code:
'Copy Macros
Dim comp As Object
Set comp = ThisWorkbook.VBProject.VBComponents("Module2")
Set Target = Workbooks("Food Specials Rolling Depot Memo 46 - 01.xlsm").VBProject.VBComponents.Add(1)
For some reason, this copies the module, but does not copy the VBA code inside, why?
Please can someone show me where i am going wrong?
Thanks
Sub CopyModule below, receives 3 parameters:
1.Source Workbook (as Workbook).
2.Module Name to Copy (as String).
3.Target Workbook (as Workbook).
CopyModule Code
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
Main Sub Code (for running this code with the Post's data):
Option Explicit
Public Sub Main()
Dim WB1 As Workbook
Dim WB2 As Workbook
Set WB1 = ThisWorkbook
Set WB2 = Workbooks("Food Specials Rolling Depot Memo 46 - 01.xlsm")
Call CopyModule(WB1, "Module2", WB2)
End Sub
Actually, you don't need to save anything to a temporary file at all. You can use the .AddFromString method of the destination module to add the string value of the source. Try the following code:
Sub CopyModule()
Dim SourceVBProject As VBIDE.VBProject, DestinationVBProject As VBIDE.VBProject
Set SourceVBProject = ThisWorkbook.VBProject
Dim NewWb As Workbook
Set NewWb = Workbooks.Add ' Or whatever workbook object you have for the destination
Set DestinationVBProject = NewWb.VBProject
'
Dim SourceModule As VBIDE.CodeModule, DestinationModule As VBIDE.CodeModule
Set SourceModule = SourceVBProject.VBComponents("Module1").CodeModule ' Change "Module1" to the relevsant source module
' Add a new module to the destination project
Set DestinationModule = DestinationVBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
'
With SourceModule
DestinationModule.AddFromString .Lines(1, .CountOfLines)
End With
End Sub
Should be self-explanatory! The .AddFomString method simply takes a string variable. So in order to get that, we use the .Lines property of the source module. The first argument (1) is the start line, and the second argument is the end line number. In this case, we want all the lines, so we use the .CountOfLines property.
Fantastic Code by Chris Melville, Thanks a ton, just a few small addition which i did & added few comments.
Just make sure, following things are done before running this macro.
VB Editor > Tools > References > (Check) Microsoft Visual Basic for Applications Extensibility 5.3
File -> Options -> Trust Center -> Trust Center Setttings -> Macro Settings -> Trust Access to the VBA Project object model.
Once you do above thing, copy & paste below code in Source File
Sub CopyMacrosToExistingWorkbook()
'Copy this VBA Code in SourceMacroModule, & run this macro in Destination workbook by pressing Alt+F8, the whole module gets copied to destination File.
Dim SourceVBProject As VBIDE.VBProject, DestinationVBProject As VBIDE.VBProject
Set SourceVBProject = ThisWorkbook.VBProject
Dim NewWb As Workbook
Set NewWb = ActiveWorkbook ' Or whatever workbook object you have for the destination
Set DestinationVBProject = NewWb.VBProject
'
Dim SourceModule As VBIDE.CodeModule, DestinationModule As VBIDE.CodeModule
Set SourceModule = SourceVBProject.VBComponents("Module1").CodeModule ' Change "Module1" to the relevsant source module
' Add a new module to the destination project
Set DestinationModule = DestinationVBProject.VBComponents.Add(vbext_ct_StdModule).CodeModule
'
With SourceModule
DestinationModule.AddFromString .Lines(1, .CountOfLines)
End With
End Sub
Now run the "CopyMacrosToExistingWorkbook" macro in destination file, you will see the source file macro copied to destination file.
I had a lot of trouble getting the previous answers to work, so I thought I'd post my solution. This function is used to programmatically copy modules from a source workbook to a newly created workbook that was also created programmatically with a call to worksheet.copy. What doesn't happen when a worksheet is copied to a new workbook is the transfer of the macros that the worksheet depends upon. This procedure iterates through all modules in the source workbook and copies them into the new one. What's more is that it actually worked for me in Excel 2016.
Sub CopyModules(wbSource As Workbook, wbTarget As Workbook)
Dim vbcompSource As VBComponent, vbcompTarget As VBComponent
Dim sText As String, nType As Long
For Each vbcompSource In wbSource.VBProject.VBComponents
nType = vbcompSource.Type
If nType < 100 Then '100=vbext_ct_Document -- the only module type we would not want to copy
Set vbcompTarget = wbTarget.VBProject.VBComponents.Add(nType)
sText = vbcompSource.CodeModule.Lines(1, vbcompSource.CodeModule.CountOfLines)
vbcompTarget.CodeModule.AddFromString (sText)
vbcompTarget.Name = vbcompSource.Name
End If
Next vbcompSource
End Sub
The function should hopefully be as simple as possible and fairly self-explanatory.
You can try
Open both workbooks
Open VBA Dev window
Dropdown Modules and drag and drop a copy from one module are to another
This is to make sure Module Names are not duplicated.
Also if you have modules that contain same named function / Subs then there will be a clash.
I do this and then run debug. Seems to work fine.
P.S. I copy many in to my PERSONAL.xlsb
I would greatly appreciate your help with a macro that I am trying to create.
I have a pathway that looks as follows: K:\XXX\XXX\XXX\Module 1
Module 1 is a folder that contains a bunch of xlsm files named with a number (i.e. 100.xlsm, 110.xlsm, and so forth)
I would like to create a loop that:
Runs the macro in workbook 100.xlsm;
Saves the 100.xlsm (NOT "save as") when the macro is done running;
Closes the saved xlsm, moves on to the next file (i.e.
110.xlsm), and repeats the same steps.
Before running the loop, I would like to create a statement that stores the names of those xlsm files.
The macro below may give you an idea of what I am after. There are indeed several errors.
Sub update()
Dim path As String path = "K:\XXX\XXX\XXX\Module 1"
Dim list() As Integer
List=(100, 110, 137, 140)
For Each n As Integer In list
Application.Run (path & "\" &n.xslm!refresh)
Save WORKBOOK
Close WORKBOOK
Next
End Sub
I think something like the code below will achieve what you are wanting to do.
Note that the code first opens the workbook whose macro you want to run.
You can then run the macro in that opened workbook from your original workbook with the Application.Run() command, e.g.
Application.Run("book1.xlsm!mymacro"), or
result = Application.Run("book1.xlsm!mymacro", "Hello", 20)
The second example calls a macro that requires a string paramater and an integer parameter.
The fuller example below opens some specific workbooks called 100.xlsm, 110.xlsm, etc and then runs a macro in each of them called SayHelloMessage.
I hope this helps.
Sub RunMacrosInOtherWorkbooks()
Dim wbpath As String 'path where the workbooks containing the macros you want to run are saved
Dim wbnames() As String 'array containing names of workbooks whose macros you want to run
Dim wbTarget As Workbook 'current workbook who macro is being run
Dim macroname As String 'name of macro being run
wbpath = "C:\Test"
wbnames() = Split("100.xlsm,110.xlsm,137.xlsm,140.xlsm", ",") 'Just one way of creating the list of workbooks.
macroname = "SayHelloMessage"
Dim i As Integer
Dim result As Variant
For i = 0 To UBound(wbnames)
Set wbTarget = Workbooks.Open(wbpath & "\" & wbnames(i))
result = Application.Run(wbTarget.Name & "!" & macroname)
' result = Application.Run(wbTarget.Name & "!" & macroname, 76) 'calling a subroutine or function with an argument. You need something to catch a return code
wbTarget.Save
wbTarget.Close
Next
End Sub
So the issue I'm having is we have a schedule program made via excel, that is set to replace all user names and shift times with "####" and where it would normally display names inputs "Contact blah blah for new version." This occured on 1/1/15. For now they can backdate their computer to a date prior to 1/1/15 and once they type a value in to any cell the worksheet runs and all their data re-appears. We have locations across the country that saves the file every two weeks to Wildcardname.xls I'm looking for a way to program a command button that finds the other random name opened workbook, goes to hidden sheet "help" and changes the value of Cell A184 to "01/01/2016" or any date I plug in. Which would remove the "####" issue and replace it with the originally inputed values. The user could then save the file and carry on.
I was browsing through various help boards and found this..prompts a user to select the workbook. This would be the workbook that needs changed.
http://www.excelforum.com/excel-programming-vba-macros/695467-copy-values-from-a-worksheet-to-another-workbook-source-workbook-name-unknown.html
Sub CopyData()
Dim DstRng As Range
Dim DstWkb As Workbook
Dim DstWks As Worksheet
Dim FileFilter As String
Dim Filename As String
Dim SrcRng As Range
Dim SrcWkb As Workbook
Dim SrcWks As Worksheet
Dim SheetName As String
SheetName = "Output Table"
FileFilter = "Excel Workbooks (*.xls), *.xls"
Filename = Application.GetOpenFilename(FileFilter, , "Open Source Workbook")
If Filename = "False" Then
MsgBox "Open Source File Canceled."
Exit Sub
End If
Set SrcWkb = Workbooks.Open(Filename)
Set SrcWks = SrcWkb.Worksheets(SheetName)
Set SrcRng = SrcWks.Range("A2:H20")
FileFilter = "Excel Workbooks (*.xls), *.xls"
Filename = Application.GetOpenFilename(FileFilter, , "Open Destination Workbook")
If Filename = "False" Then
MsgBox "Open Destination File Canceled."
Exit Sub
End If
Set DstWkb = Workbooks.Open(Filename)
Set DstWks = DstWkb.Worksheets(SheetName)
Set DstRng = DstWks.Range("A2:H20")
SrcRng.Copy Destination:=DstRng
End Sub
Can this be modified to accomplish what I want to complete?
I can't post an image yet, so here's a link to a mock up. Before shot of the program on the left, and on the right is what I want it to look like.
http://i528.photobucket.com/albums/dd330/DLN1223/mockup.jpg
Hopefully this description makes since....
Thanks in advance for your help.
This is what I use:
Dim FileToOpen As Variant
Dim WKbook as workbook
FileToOpen = Application.GetOpenFilename("Excel files (*.xlsx),*.xlsx", , "Select Workbook to Open")
If FileToOpen = False Then Exit Sub 'quit on cancel
Set Wkbook = Workbooks.Open(FileToOpen, False, False)
With this, I can the set the value I want, and save changes
Wkbook.Sheets("help").Range("A184")=#1/1/2016#
Wkbook.Close SaveChanges:=True
depending on the filetype, you may need to change Excel files (*.xlsx),*.xlsx to Excel files (*.xls),*.xls