I've two excel vba workbooks: 'Formini1.xlsm' as the source file; 'Tampil1.xlsm' as the target file.
The main fuction is: I've an advanced filter search in the target file. When I write a keyword and click the button this workbook, it searches in the source file and displays the related data in the target file.
Here's the code:
Private Sub CommandButton1_Click()
Dim RangeKriteria As Range, RangeCopyTo As Range, RangeTabel As Range
Set RangeTabel = Workbooks("formini1.xlsm").Sheets("Sheet3").[A1].CurrentRegion
Set RangeCopyTo = Workbooks("tampil1.xlsm").Sheets("Sheet2").[L1]
Set RangeKriteria = Workbooks("tampil1.xlsm").Sheets("Sheet2").[A1:I10]
With Workbooks("tampil1.xlsm").Sheets("Sheet2")
.Cells.Clear
.[A1:I1].Value = Workbooks("formini1.xlsm").Sheets("Sheet3").[A1:I1].Value
.[A2].Value = "*" & TextBox1.Value
.[B3].Value = "*" & TextBox1.Value
RangeTabel.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=RangeKriteria _
, CopyToRange:=RangeCopyTo, _
Unique:=False
End With
End Sub
The problem is, in real implementation the source file ("formini1.xlsm")doesn't/mustn't always be opened. Is there any idea to fix the problem?
You need to open the source file if it's closed. Add the following:
Sub Macro3()
Dim book As Workbook
Dim filepath As String
filepath = "C:\your_path\formini1.xlsm"
'Open the workbook as read only to avoid access conflicts
Set book = Workbooks.Open(Filename:=filepath, ReadOnly:=True)
' Close the workbook after you have read the data
book.Close
End Sub
I tested having the file already open, and for me, it did not fail. If it does fail if already open, trap for the error and continue.
Related
I have a workbook which opens up another workbook (filename is based on a cell value) and then runs a macro called Single_sector within that file.
It opens the file perfectly fine but doesn't run the macro. Any ideas?
Sub run_all()
Dim Location
On Error Resume Next
'Location of file to open
Location = Worksheets("Main").Range("folder_location").Value
'Open F&V File
Application.Workbooks.Open Location & Range("fv_file").Value
'Run Macro
Run ("Single_sector")
End Sub
Place the following code in the macro calling the other workbook:
Location = Worksheets("Main").Range("folder_location").Value
Set wb = Workbooks.Open(Location & Range("fv_file").Value)
Application.Run "'" & wb.Name & "'!" & strSubToRun, Parameters
Set wb = Nothing
Parameters is an array of arguments that you want to pass, so the sub in the other workbook should look something like
Public Sub TheSub(ParamArray X())
Dim i As Long
Sheet1.Cells(1, 1).Value = "Parameters passed:"
For i = 0 To UBound(X(0))
Sheet1.Cells(i + 2, 1).Value = CStr(X(i))
Next
End Sub
Probably not very elegant but:
Dim Location As String
Location = "\\location\to\file.xlsm"
Workbooks.Open(Location).RunAutoMacros (xlAutoOpen)
Where you have an Auto_Open Sub in your other excel file to handle the macros to run on your other spreadsheet
Please make sure your code in another workbook is at Workbook_open event so you dont need to use Run ("Single_sector"). The procedure single_selector would trigger as soon as another workbook is open.
Updated answer
Sub run_all()
Dim Location
On Error Resume Next
Dim wkb As Workbook
'Location of file to open
Location = Worksheets("Main").Range("folder_location").Value
'Open F&V File
Set wkb = Workbooks.Open(Location & Range("fv_file").Value)
wkb.Sheets(1).Single_sector ' kindly put this proc in another workbook sheet1
End Sub
Does there exist a code to for example save every hour the data from A1:B10 in sheet1 to a CSV file ?
Although this can be done in many different ways, this is what I'd do:
1) Add the following sub to a new file. Let's call it "auto.xlsb"
Sub SaveRangeToCSV()
Dim rng As Range
Dim originWB As Workbook
Dim originWS As Worksheet
Dim newBook As Workbook
Dim newBookWS As Worksheet
'Open the file you want to copy the range from
Set originWB = Workbooks.Open("path_to_file_that_contains_the_range_you_want_to_copy.xlsx")
Set originWS = ThisWorkbook.Sheets("name_of_the_sheet_where_the_range_is")
Set rng = originWS.Range("A1:B10")
'Add new workbook (csv file)
Workbooks.Add
Set newBook = ActiveWorkbook
Set newBookWS = newBook.Sheets(1)
'Copy range from origin to destination (csv file)
rng.Copy Destination:=newBookWS.Range("A1")
'Save csv file
newBook.SaveAs Filename:=ThisWorkbook.Path & "\output.csv"
End Sub
If you want to avoid the output.csv to be overwritten every 10 minutes, you could, for example, add current datetime to the filename like this:
'Save csv file
newBook.SaveAs Filename:=ThisWorkbook.Path & "\output_" & Replace(Replace(Replace(Now, "/", ""), ":", ""), " ", "") & ".csv"
2) Add this code to Workbook_Open Sub (click ThisWorkbook sheet in VBA IDE, and select Workbook and Open from the dropdown) in auto.xlsb, and Save:
Private Sub Workbook_Open()
Call Module1.SaveRangeToCSV
End Sub
Every time you doble-click to open the file, SaveRangeToCSV will be triggered and, hence, the csv created.
3) Automating the execution of this file really depends on your preferences and the Operating System you are working on. I'm assuming your are on Windows, so the easiest way to do it would be creating a task in Windows' Task Scheduler which runs "auto.xlsb" every 10 minutes.
I hope this helps.
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 have a workbook which opens up another workbook (filename is based on a cell value) and then runs a macro called Single_sector within that file.
It opens the file perfectly fine but doesn't run the macro. Any ideas?
Sub run_all()
Dim Location
On Error Resume Next
'Location of file to open
Location = Worksheets("Main").Range("folder_location").Value
'Open F&V File
Application.Workbooks.Open Location & Range("fv_file").Value
'Run Macro
Run ("Single_sector")
End Sub
Place the following code in the macro calling the other workbook:
Location = Worksheets("Main").Range("folder_location").Value
Set wb = Workbooks.Open(Location & Range("fv_file").Value)
Application.Run "'" & wb.Name & "'!" & strSubToRun, Parameters
Set wb = Nothing
Parameters is an array of arguments that you want to pass, so the sub in the other workbook should look something like
Public Sub TheSub(ParamArray X())
Dim i As Long
Sheet1.Cells(1, 1).Value = "Parameters passed:"
For i = 0 To UBound(X(0))
Sheet1.Cells(i + 2, 1).Value = CStr(X(i))
Next
End Sub
Probably not very elegant but:
Dim Location As String
Location = "\\location\to\file.xlsm"
Workbooks.Open(Location).RunAutoMacros (xlAutoOpen)
Where you have an Auto_Open Sub in your other excel file to handle the macros to run on your other spreadsheet
Please make sure your code in another workbook is at Workbook_open event so you dont need to use Run ("Single_sector"). The procedure single_selector would trigger as soon as another workbook is open.
Updated answer
Sub run_all()
Dim Location
On Error Resume Next
Dim wkb As Workbook
'Location of file to open
Location = Worksheets("Main").Range("folder_location").Value
'Open F&V File
Set wkb = Workbooks.Open(Location & Range("fv_file").Value)
wkb.Sheets(1).Single_sector ' kindly put this proc in another workbook sheet1
End Sub