I have a button in my GUI which calls this procedure:
Private Sub CommandButtonPersonalFilter_Click()
Unload GUI
Dim myPath As String
Dim Wb As Workbook
myPath = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1)
If Dir(myPath & "\filterPartsList.xlsx") = "" Then
FileCopy "Z:\Dokumentstyring\Templates\filterPartsList.xlsx", myPath & "\filterPartsList.xlsx"
End If
Set Wb = HelpFunctions.GetWorkbook(myPath & "\filterPartsList.xlsx")
Wb.Activate
Wb.Sheets(1).Range("A1").Select
Set Wb = Nothing
End Sub
When I click the button(from a.xlsx) it opens up a new workbook(b.xlsx, all as it should), but if I then decide that the b.xlsx is just fine and I would like to close b.xlsx (or edit), then I am only allowed to do so if I first jump back to a.xlsx, click on any cell there and then jump back to the b.xlsx
Below is the helper function:
Public Function GetWorkbook(ByVal sFullName As String) As Workbook
Dim sFile As String
Dim wbReturn As Workbook
sFile = Dir(sFullName)
On Error Resume Next
Set wbReturn = Workbooks(sFile)
If wbReturn Is Nothing Then
Set wbReturn = Workbooks.Open(sFullName)
End If
On Error GoTo 0
Set GetWorkbook = wbReturn
End Function
Not a big issue but would be nice to figure out where the problem might be. All macros are stored in personal.xlsb
Related
I'm trying to combine/nest 3 different functions in Excel VBE: open, loop, and click. I have them written out separately, but am unsure of how to combine them. I've tried the "call macro" function but got a compile error returned to me.
The goal is to open a bunch of files within a certain folder and click on the URL in all of them (the URL will not always be the same, so I need a click function that targets any unknown URL within a sheet).
Open macro:
Sub openMyfile()
Dim Source As String
Dim StrFile As String
Source = "/users/kmogilevsky/Desktop/IC_new/"
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Do While Len(StrFile) > 0
Workbooks.Open Filename:=Source & StrFile
StrFile = Dir("/users/kmogilevsky/Desktop/IC_new/")
Loop
End Sub
Loop macro:
Sub LoopThroughFiles()
Dim MyObj As Object, MySource As Object, file As Variant
Set MySource = MyObj.GetFolder("/users/kmogilevsky/Desktop/IC_new/")
For Each file In MySource.Files
If InStr(file.Name, "test") > 0 Then
End If
Next file
End Sub
Click macro (this needs some work):
Private Sub CommandButton1_Click()
Call NewSub
End Sub
Sub ReadWorkbooksInCurrentFolder()
Dim wbDst As Workbook
Dim wbSrc As Workbook
Dim MyPath As String
Dim strFilename As String
'Stop annoying popups while macro is running
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
'When working with many open workbooks its good to explicitly reference all workbooks, makes sure your code works and easier to read, understand and remember which workbook is which.
Set wbDst = ThisWorkbook
srcSheetName = "Data"
dstSheetName = "Results"
'I want to loop through all .xlsx files in the folder
MyPath = ThisWorkbook.Path
strFilename = Dir(MyPath & "\*.xlsx", vbNormal)
If Len(strFilename) = 0 Then
MsgBox "No workbooks found ending in .xlsx in current folder"
Exit Sub
End If
Do Until strFilename = ""
Set wbSrc = Workbooks.Open(Filename:=MyPath & "\" & strFilename)
Call CollectData(wbDst, wbSrc, dstSheetName, srcSheetName)
wbSrc.Close
strFilename = Dir()
Loop
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Sub CollectData(ByRef wbDst as Workbook, ByRef wbSrc as Workbook, dstSheetName as String, srcSheetName as String)
'Copy cell A1 contents in source workbook to destination workbook cell A1
wbDst.Sheets(dstSheetName).Range("A1") = wbSrc.Sheets(srcSheetName).Range("A1")
End Sub
Please edit the subroutine CollectData() so that it suits your needs, i.e. performs the click / url open. (I am not familiar with opening urls from excel, but I loop through workbooks often)
This code will open all Excel files in the IC_New folder on the desktop.
It will then look at each sheet and follow any hyperlinks that are on the sheet.
Sub Open_ClickHyperlinks()
Dim sPath As String
Dim vFiles As Variant
Dim vFile As Variant
Dim wrkBk As Workbook
Dim wrkSht As Worksheet
Dim HLink As Hyperlink
sPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") & Application.PathSeparator & _
"IC_New" & Application.PathSeparator
'Return all files that have an extension starting with xls.
vFiles = EnumerateFiles(sPath, "xls*")
'Loop through each file.
For Each vFile In vFiles
'Open the file
Set wrkBk = Workbooks.Open(Filename:=vFile, UpdateLinks:=False)
With wrkBk
'Loop through each worksheet in the file.
For Each wrkSht In .Worksheets
'Loop through each hyperlink on the worksheet.
For Each HLink In wrkSht.Hyperlinks
HLink.Follow
Next HLink
Next wrkSht
.Close SaveChanges:=False
End With
Next vFile
End Sub
'Get all files in the specified folder, default to include all subfolders as well.
Public Function EnumerateFiles(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
I have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore
I currently have a list of files with the file path (C:/something.xlxs) in column B of a sheet. I want to write a Macro to read the value from the cell, open the file, and then move on to the next cell and open that file, etc.
I currently have this:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
For i = 1 To 5
If Not IsEmpty(Cells(i, 2)) Then
sFullName = Cells(i, 2).Value
Workbooks.Open fileName:=Cells(i, 2).Value, UpdateLinks:=0
End If
Next i
End Sub
It is only opening the first file from the list and then stopping. It is probably a small error but I am having trouble spotting it.
Thanks
I would do it this way:
Sub openFiles()
Dim sFullName As String
Dim i As Integer
Dim wsh As Worksheet
On Error GoTo Err_openFiles
Set wsh = ThisWorkbook.Worksheets("Sheet1")
i = 1
Do While wsh.Range("B" & i)<>""
sFullName = wsh.Range("B" & i)
Application.Workbooks.Open sFullName, UpdateLinks:=False
i = i+1
Loop
Exit_openFiles:
On Error Resume Next
Set wsh = Nothing
Exit Sub
Err_openFiles:
MsgBox Err.Description, vbExclamation, Err.Number
Resume Exit_openFiles
End Sub
Above code works in context and provides a way to handle errors.
Try
Dim wb As Excel.Workbook
Set wb = Workbooks.Open(Filename:=sFullName)
This is not a duplicate of:
Can I set a Excel Application Object to point to an already open instance of Excel?
The idea is to execute a VBA sub contained in an Excel instance that is already open from Outlook
I am running the VBA sub as part of a rule in Outlook.
This is my code:
On Error Resume Next
Dim tPath As String
tPath = "X:\Lucas\LucasSheet.xlsm"
Dim exApp As New Excel.Application
Dim wb As Excel.Workbook
wb = System.Runtime.InteropServices.Marshal.BindToMoniker(tPath)
Unfortunately at this point, when running in debug mode I can see that wb is equal to Nothing
Set exApp = wb.Parent
usedSub = "PrintSingle"
exApp.Run usedSub
wb.Close False
Is it possible to make this code work in Outlook 2010?
Instead of creating a new Excel Application in the code:
Dim exApp As New Excel.Application
You need to get the running Excel instance :
exApp = System.Runtime.InteropServices.Marshal.GetActiveObject("Excel.Application");
See Access running instances of Excel in VB for more information and sample code in VB.NET.
Use the Run method of the Application class to run the VBA macro programmatically.
First you need a function that will attach to a running instance of Excel and then look for a workbook by name.
'#Description "Return the open Excel workbook"
Public Function GetHandleForExistingWorkbook(ByVal fullPath As String) As Object
On Error GoTo openExcel
Dim excelApp As Object
Set excelApp = GetObject(, "Excel.Application")
Dim wb As Object
For Each wb In excelApp.Workbooks
If wb.FullName Like fullPath & "*" Then
Set GetHandleForExistingWorkbook = wb
Exit For
End If
Next wb
Exit Function
openExcel:
If Err.Number = 429 Then
' Open it if it wasn't already open
Set excelApp = CreateObject("Excel.Application")
GetHandleForExistingWorkbook = excelApp.Workbooks.Open(fullPath)
Else
Debug.Print "Unhandled exception: " & Err.Number & " " & Err.Description
End If
End Function
Once you know you are in the correct place you can run the macro by calling on the Excel Application object:
Public Sub RunMacroInOpenWorkbook(ByVal fullPath As String, ByVal macroName As String, _
Optional ByVal macroParameters As String = "")
Dim theWorkBook As Object
Set theWorkBook = GetHandleForExistingWorkbook(fullPath)
theWorkBook.Application.Run "'" & theWorkBook.Name & "'!" & macroName, macroParameters
theWorkBook.Close False
End Sub
Then your code to use this would look like this:
Dim tPath As String
tPath = "X:\Lucas\LucasSheet.xlsm"
usedSub = "PrintSingle"
RunMacroInOpenWorkbook tPath, usedSub
You need to include the workbook name when using the Application.Run command.
Try using this:
exApp.Run wb.Name & "!" & usedSub ' must include workbook name
Set wb = Workbooks(Filename)
Set codeModule = wb.VBProject.VBComponents("ThisWorkbook").codeModule
codeModule.InsertLines 3, "Hej jag kan spara detta"
wb.Save
Down below is my function. I want to unlock vbaproject and write in ThisWorkbook. For some reason when I incorporate the above 4 lines (at **), the workbook is not unlocked and the line "Hej jag kan spara detta" is not applied to ThisWorkbook. However, without these 4 rows, the workbook is unlocked. And if the workbook is unlocked before running the code, the same 4 lines also work. What is wrong?
Sub merniplusplus()
Dim path As String
Dim Filename As Variant
Dim wb As Workbook
Dim CodeModule As Variant
path = "C:\Merni\"
Filename = Dir(path & "*.xls")
Do While Filename <> ""
If Filename <> "merni.xlsm" Then
UnprotectPassword Workbooks(Filename), "2lbypo"
Set wb = ActiveWorkbook
Set CodeModule = wb.VBProject.VBComponents("ThisWorkbook").CodeModule
CodeModule.InsertLines 3, "Hej jag kan spara detta"
wb.Save
End If
Filename = Dir()
Loop
End Sub
Sub UnprotectPassword(wb As Workbook, ByVal projectPassword As String)
Dim currentActiveWb As Workbook
If wb.VBProject.Protection <> 1 Then
Exit Sub
End If
wb.Unprotect "poWorkbook"
Set currentActiveWb = ActiveWorkbook
wb.Activate
SendKeys "%{F11}"
SendKeys "^r" ' Set focus to Explorer
SendKeys "{TAB}" ' Tab to locked project
SendKeys "~" ' Enter
SendKeys projectPassword
SendKeys "~" ' Enter
If (wb.VBProject.Protection = vbext_pp_locked) Then
MsgBox ("failed to unlock")
End If
currentActiveWb.Activate
End Sub
Two things
Filename = Dir() should be before the loop and not before those 4 lines. Else you will get a different Filename.
Also the 4 lines should be inside your If Filename <> "merni.xlsm" Then Condition
Also you might want to close the workbook before you open the new one. Else you will have lot of workbooks open :)
FOLLOWUP
You are not opening the workbook but setting it to the current workbook every time and hence it is not working. I have tested the code below and it works just fine.
Sub merniplusplus()
Dim path As String, Filename As String
Dim wb As Workbook
Dim CodeModule As Variant
path = "C:\Merni\"
Filename = Dir(path & "*.xls")
Do While Filename <> ""
If Filename <> "merni.xlsm" Then
Set wb = Workbooks.Open(path & Filename)
UnprotectPassword wb, "2lbypo"
Set CodeModule = wb.VBProject.VBComponents("ThisWorkbook").CodeModule
CodeModule.InsertLines 3, "Hej jag kan spara detta"
wb.Close SaveChanges:=True
End If
Filename = Dir
Loop
End Sub