GetOpenFileName opens in background - excel

I have a macro that prompts the user to select a comma separated values file, however, whenever the macro runs, it opens the window behind all the other open windows. The macro is never called from excel, but only by other scripts. I've tried messing with Application.DisplayAlerts and Application.ActiveWindow but to no avail. Any suggestions are greatly appreciated.
Function folderselection()
Dim fnameandpath As Variant
Dim path As String
Dim objshell As Object
Set objshell = CreateObject("wscript.shell")
objshell.AppActivate "excel"
Application.DisplayAlerts = False
path = ActiveWorkbook.path
ChDrive (path)
ChDir (path)
Application.ActiveWindow.Visible = True
Application.WindowState = xlMaximized
fnameandpath = Application.GetOpenFilename(FileFilter:=("BOM CSV/RPT (*.CSV;*.RPT), *.CSV; *.RPT"), Title:="Select The BOM File To Copy Values From")
Application.WindowState = xlMinimized
If fnameandpath = False Then Exit Function
Workbooks.Open Filename:=fnameandpath, ReadOnly:=True
Application.DisplayAlerts = True
folderselection = CStr(fnameandpath)
ActiveWorkbook.Close
End Function

Looking at some sections of your code:
Function folderselection()
Dim fnameandpath As Variant
...
fnameandpath = Application.GetOpenFilename(...
...
folderselection = CStr(fnameandpath)
These lines are redundant. This accomplishes the same thing with half the code (and is therefore simpler):
Function folderSelection() as String
...
folderSelection = Application.GetOpenFilename(...
Dim path As String
path = ActiveWorkbook.path
ChDrive (path)
ChDir (path)
These lines accomplish nothing. The GetOpenFilename dialog defaults to the same folder as ActiveWorkbook.Path.
Dim objshell As Object
Set objshell = CreateObject("wscript.shell")
objshell.AppActivate "excel"
These lines don't do anything either. I think you might be trying to activate the existing Excel window? If so, you need to read the documentation for these commands.
I guarantee you don't have a Title Bar called excel. You might have one called "Book1.xlsm - Excel", but that's irrelevant because you don't need to activate the current window unless you were using another application in the 0.01 seconds since you [I assume] manually executed this procedure.
Furthermore, objects need to be handled certain ways, such as freeing up the memory when you're finished with them (ie, Set ... Nothing; see "crashes" below) otherwise, some processes will just remain in memory, taking up space, until you reboot.
It's important to understand that some commands should be at least partially understood before arbitrarily using them, since you could have unexpected results. In this case the Windows Script Host (wscript), as well as calling "outside" command-line programs (shell.exe) can/will impact other applications and/or cause crashes.
Application.DisplayAlerts = False
Application.DisplayAlerts = True
This isn't accomplishing anything related to what you're trying to do (and certain setting should be used sparingly or not at all -- like disabling warnings or security alerts in code that isn't functioning properly to begin with. Just leave those lines out.
Application.ActiveWindow.Visible = True
The Active Window is, by definition, Visible already. This line does nothing.
Application.WindowState = xlMaximized
Application.WindowState = xlMinimized
Seriously? Obviously these "cancel each other out", not to mention that the "last" one leaves the window minimized. Isn't "not being able to see the window" your main issue?
fNameAndPath = Application.GetOpenFilename(FileFilter:=("BOM CSV/RPT (*.CSV;*.RPT), *.CSV; *.RPT"), Title:="Select The BOM File To Copy Values From")
Ironically, the command that you figured is the problem, is actually the only line that was functioning properly (regardless of minor syntax and organization issues). Little things like spacing and using "exact documented syntax" canm end up having an an impact on the success of your code, and are especially important while still in the troubleshooting stage.
Matching the command's documentation, plus changing the destination as mentioned above:
folderSelection = Application.GetOpenFilename("Comma Separated Files (*.csv),*.csv,Report Files (*.rpt),*.rpt.", 1, "Select the Source BOM File")
If fNameAndPath = False Then Exit Function
Nothing wrong with that line! Personally, I would use:
If Not fNameAndPath Then Exit Function
...but the result is the same.
Workbooks.Open Filename:=fNameAndPath, ReadOnly:=True
Following the documentation, a better way to phrase that line would be:
Workbooks.Open Workbooks.Open fNameAndPath, , True, 2
The 2 specifies comma delimiting. Since you specified that the file is comma-separated, I will assume that the other option you specified (an ".RPT" file) is also a text-based, comma-separated file.
That line probably would have functioned okay as it was, which is good since it's a key part of your subroutine.
Except that, 0.01 seconds later, the very last command closes the file that you just opened:
ActiveWorkbook.Close
With VBA and/or Excel there are often (usually?) multiple ways to accomplish the same task, adding to flexibility and ease-of-use that have made Excel common-place on almost "every desk and in every home." [Anyone else catch that reference?!]
Unfortunately the flip side (very common around here) is users over-complicating tasks unnecessarily; even [unknowingly] attempting to build functionality from scratch - that's already built-in to Excel and the rest of the Office Suite.

Related

I need help replacing Application.Find with a new function for this old macro

I have an old 2003 xls macro that extracts data from all excel dump files in an "inbox" type subfolder. The files are generated daily and as far as I can tell from this old code, the Application.Find looks up all files it can find in this inbox and then goes through them one by one to sort the data and place it properly in the main document.
The problem of course is that Application.Find is used and does not exist in Excel anymore, requiring the use of the old Excel version to execute this macro. It's a pain to have to run an old version for the import of data and then a new version for all the other needs so I was hoping I could get some help to replace this old code with a new function that serves the same role.
I've looked around here and other places for peoples functions to find x amount of files in a given location and go through them one by one but I am not all that good at trying to integrate these more modern solutions with this older macro as it already has a structure in place to loop until all the Application.Find results have been completed.
I tried a Dir approach but was unsuccessful and I can't manage to get a filecount/array thing going so it can just work through whatever it finds in that subfolder.
With Application.FileSearch
.NewSearch
.LookIn = inbox
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set basebook = ThisWorkbook
For i = 1 To .FoundFiles.Count
Set mybook = Workbooks.Open(.FoundFiles(i))
The expected result is that this can loop harmlessly when executed since further down in the code after having gone through the data in the opened document, it will ask for the Next i and keep going until running out of files. However, as Application.Find no longer exists, it just stops at that point with the expected error message unless I run the 2003 version.
Any help at all would be really appreciated!
This is how I loop through all the files in a folder:
Option Explicit
Sub Test()
Dim FilePath As String, FileName As String
Dim wb As Workbook
FilePath = "Your Path"
FileName = Dir(FilePath & "*.xls*")
Do While FileName <> ""
Set wb = Workbooks.Open(FilePath & FileName, UpdateLinks:=False, ReadOnly:=True)
'Your Code
FileName = Dir
Loop
End Sub
In this case, as you can see, looking for any file which extension containts xls so... xls, xlsx, xlsm, xlsb...
Hope it helps

VBA in Access Looping through multiple excel workbooks Subscript out or Range error

I have been working with this issue for days. I tried multiple different ways. I am attempting to append multiple files into an Access linked table or even a temp table or even into a single excel file. At first EVERY SINGLE TIME on the first attempt the program works perfectly, then after that it stops functioning for a period of time and then starts operating again. When it stop functioning I get an Subscript out of range run-time error 9.I open the proper excel file but for some reason it won't let me set it... How can it OPEN THE FILE but in the next line CAN'T FIND IT??? It is driving me insane, it works, it stops working, then it works again... Any advice or hints would be very much appreciated.
This is just one way I tried to do this but they all end the same.
i = 2 'i is created through another loop previously.
j = 0
With MyXL
.Visible = True
.DisplayAlerts = True
End With
Do
Set MyXL = CreateObject("Excel.Application")
MyXL.Workbooks.Open Directory & fileArray(j), Notify:=False, ReadOnly:=False 'Tried True previously but changed since i was making changes to the file.
Set wb = Workbooks(fileArray(j)) 'DING DING DING!!! WHY??? You WORKED before!!!
If wb.Sheets("Sheet1").Range("A1") = "System Status" Then
wb.Sheets("Sheet1").Range("A1") = "PO System Status"
wb.Save
End If
wb.Close True
Set wb = Nothing
MyXL.Quit
Set MyXL = Nothing
Set wb = Nothing
j = j + 1
Loop Until j = i
Previously I thought I wasn't closing the workbook correctly, but I have closed the MyXL and previous wb but i still run into the error. I was wondering if this is something that Access/vba just can't do in succession as well. I changed the ReadOnly to true and it still ends up the same way.
Set your workbook to the return value from the Open method:
Set wb = MyXL.Workbooks.Open(Directory & fileArray(j), Notify:=False, ReadOnly:=False)
If wb.Sheets("Sheet1").Range("A1") = "System Status" Then
wb.Sheets("Sheet1").Range("A1") = "PO System Status"
wb.Save
End If
You don't need to/shouldn't create a new Excel application instance for every file - set that up before you enter the loop, and close it once you're done updating files. Check your Task Manager and make sure you don't have a bunch of Excel instances hanging around.

How to save workbook and handle TITUS (or any other document classification add-in) popup?

I'm creating a script in HP UFT 12 which performs grid data validation against a CSV file and saves the results in a Excel file with two worksheets.
I'm using Excel for this because it is much more clear for the user, as it allows cell formatting, is easier to compare the data and so forth.
My code works in my machine, but my client has TITUS document classification add-in installed, so every time they run my script, it hangs because of the TITUS pop-up message that asks user to classify the document upon saving. The message is not displayed to the user, probably because of objExcel.DisplayAlerts = False, but the script does not move forward.
Following is the portion of my code which is related to the matter (I have omitted most of the code, for confidentiality reasons).
Dim objExcel : Set objExcel = CreateObject("Excel.Application")
Dim objWorkbook : Set objWorkbook = objExcel.Workbooks.Add
objExcel.Visible = False
Dim wsGrid : Set wsGrid = objWorkbook.Worksheets(1)
wsGrid.Name = "Grid Data"
Dim wsExported : Set wsExported = objWorkbook.Worksheets.Add
wsExported.Name = "Exported Data"
' Internal code to perform validation and fill worksheets ...
objExcel.DisplayAlerts = False
objWorkbook.SaveAs "C:\my_folder_path\my_file_name.xls" ' This is where it hangs in machines where the add-in is installed
objWorkbook.Close
objWorkbook.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing
I have searched online but haven't find anything related to it so far. I did find this and this, but they are related to TITUS for Outlook and in neither one the issue is properly solved.
Does anyone know how to solve this, or can point me to a research material to help me solve this issue?
Thanks in advance.
As ridiculously simple as it looks (I don't know how I haven't thought of this before), I manage to solve my issue by simply adding objExcel.EnableEvents = False before saving the file:
objExcel.DisplayAlerts = False
objExcel.EnableEvents = False ' this is the problem solver for the matter!
objWorkbook.SaveAs "C:\my_folder_path\my_file_name.xls"
objExcel.EnableEvents = True ' Not sure if this statement is necessary, though
objWorkbook.Close
objWorkbook.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing
So far as I can tell, none of the above answers actually classify the Excel workbook (and I found this on our work intranet having failed to find any code on the internet).
The code below should set Classification as Internal which can be amended as you need, and will also create the footer text based on 'ClassificationVal'.
Code then sets the classification, adds the left footer and removes the annoying page breaks at the same time (note: setting classification automatically sets page breaks).
Disabling events before save seems to be the only way to avoid the pop up box...
Note: you will need to replace '[Company Name]-' with e.g. 'IBM-' (if your company adds it's name to the classification, and delete '[Company Name]-' if they use the TITUS classification only. Also, the classifications seem to be bespoke to each company from my experience, so you may need to update accordingly.
ClassificationVal = "[Company Name]-1nternal"
ClassificationDesc = "[Company Name]: "
ClassificationDesc2 = ""
Select Case ClassificationVal
Case "[Company Name]-1nternal"
ClassificationDesc2 = "Internal"
Case "[Company Name]-pub1ic"
ClassificationDesc2 = "Public"
Case "[Company Name]-Confidentia1"
ClassificationDesc2 = "Confidential"
Case "[Company Name]-5ecret"
ClassificationDesc2 = "Secret"
Case "[Company Name]-pr1vate"
ClassificationDesc2 = "Private"
End Select
If ClassificationDesc2 = "" Then Stop
ClassificationDesc = ClassificationDesc & ClassificationDesc2
With ActiveWorkbook.CustomDocumentProperties
.Add Name:="[Company Name]Classification", _
LinkToContent:=False, _
Type:=msoPropertyTypeString, _
Value:=ClassificationVal
End With
For Each ws In ActiveWorkbook.Worksheets
ws.PageSetup.LeftFooter = ClassificationDesc
ws.DisplayPageBreaks = False
Next ws
Application.EnableEvents = False 'disable TITUS pop-up
ActiveWorkbook.SaveAs Filename:= _
"C:\Data\kelvinj\My Documents\TITUS Test.xlsx", 'Change to suite your requirements
FileFormat:=xlOpenXMLWorkbook _
, CreateBackup:=False
Application.EnableEvents = True
Not sure why this is so hard to find a solution to - this is the 2nd multinational company I've worked for to be infected by TITUS, so there must be loads of people needing this code surely?!
I am not a VBA coder but my friends were working on this
The solution we found was on the behaviour of Titus
It will ask you to classify any new workbook when u save it. Note new not an already saved workbook.
So we created a blank workbook and saved it(with the required classification)
Amended the code to take that workbook and add data to it and using save as to create the required files
It works smoothly without any issues.

Best way to replace VBA code in multiple files?

I used to use something like this:
Dim vbaComponent As Variant
For Each vbaComponent In inputWorkbook.VBProject.VBComponents
vbaComponent.CodeModule.DeleteLines 1, vbaComponent.CodeModule.CountOfLines
vbaComponent.CodeModule.AddFromFile importComponentFileName
Next vbaComponent
This worked perfectly for some time but now it crashes when the Excel file gets saved. I guess the files got too big or something.
Is there better way to do this?
EDIT:
The problem seems to be frm and cls files. The replacement of bas files works perfectly.
EDIT2:
On some machines even bas files don't work.
EDIT3 (My current solution):
So my current solution was simply doing it by hand once and recording all mouse and keyboard input and then replaying this over and over again.
If there is no proper solution to this I plan on creating an AutoIt script for this.
you will have to export/import components, because not all lines are exposed to CodeModule, here is sample
Private Sub exportImportComponent(Project1 As VBIDE.VBProject, Project2 As VBIDE.VBProject)
Dim i As Long, sFileName As String
With Project1.VBComponents
For i = 1 To .Count
sFileName = "C:\Temp\" & .Item(i).Name
Select Case .Item(i).Type
Case vbext_ct_ClassModule
.Item(i).Export sFileName & ".cls"
Project2.VBComponents.Import sFileName & ".cls"
Case vbext_ct_StdModule
.Item(i).Export sFileName & ".bas"
Project2.VBComponents.Import sFileName & ".bas"
Case vbext_ct_MSForm
.Item(i).Export sFileName & ".frm"
Project2.VBComponents.Import sFileName & ".frm"
Case Else
Debug.Print "Different Type"
End Select
Next
End With
End Sub
I can assure everybody because I am working on this subject for years now (I gave up several times). When the code is programmatically modified either line-based or - what my preferred approach is 1. rename, 2. delete the renamed, 3. re-import from export file, Workbook Save will crash, will say Excel closes the Workbook. In fact my approach works most of the time but since it is unpredictable I learned to live with it. In most cases the code change has already successfully been done. So I just reopen the Workbook and continue.
The code I use. I just removed all the execution trace and execution log code lines but some lines may still look a bit cryptic:
With rn_wb.VBProject
'~~ Find a free/unused temporary name and re-name the outdated component
If mComp.Exists(wb:=rn_wb, comp_name:=rn_comp_name) Then
sTempName = mComp.TempName(tn_wb:=rn_wb, tn_comp_name:=rn_comp_name)
'~~ Rename the component when it already exists
.VBComponents(rn_comp_name).Name = sTempName
.VBComponents.Remove .VBComponents(sTempName) ' will not take place until process has ended!
End If
'~~ (Re-)import the component
.VBComponents.Import rn_raw_exp_file_full_name
'~~ Export the re-newed Used Common Component
Set Comp = New clsComp ' class module provides the export files full name
With Comp
Set Comp.Wrkbk = rn_wb
.CompName = rn_comp_name
End With
.VBComponents(rn_comp_name).Export Comp.ExpFileFullName
'~~ When Excel closes the Workbook with the subsequent Workbook save it may be re-opened
'~~ and the update process will continue with the next outdated Used Common Component.
'~~ The (irregular) Workbook close however may leave the renamed components un-removed.
'~~ When the Workbook is opened again these renamed component may cause duplicate declarations.
'~~ To prevent this the code in the renamed component is dleted.
' EliminateCodeInRenamedComponent sTempName ' this had made it much less "reliablele" so I uncommented it
SaveWbk rn_wb ' This "crahes" every now an then though I've tried a lot
End With
Private Sub SaveWbk(ByRef rs_wb As Workbook)
Application.EnableEvents = False
DoEvents ' no idea whether this helps. coded in desparation. at least it doesn't harm
rs_wb.Save
DoEvents ' same as above, not executed when Excel crashes
Application.EnableEvents = True
End Sub

VBA Code to Convert CSV to XLS

Objective: I have a folder where multiple CSVs are dumped on my drive. These CSVs need to be converted to XLS files and saved (as XLS files) into the same, original folder. I have a code (pasted below) for it that works just fine, but...
Problem: A window pops up each time saying "Code execution has been interrupted," allowing me to Continue, End, or Debug. I can click Continue each time the window pops up (it pops up for each file that needs to be converted) and the script will work perfectly, but of course, I'd rather not have to click Continue potentially hundreds of times. The asterisk'd part of the code below is the part that is highlighted upon clicking Debug.
Sub Convert_CSV_XLS()
Dim wb As Workbook
Dim strFile As String, strDir As String
strDir = "xx:\xx\xx\xx\xx\xx\xx\xx\"
strFile = Dir(strDir & "*.csv")
Do While strFile <> ""
Set wb = Workbooks.Open(Filename:=strDir & "\" & strFile, Local:=True)
**wb.SaveAs Replace(wb.FullName, ".csv", ".xls"), 56**
wb.Close SaveChanges:=False
Set wb = Nothing
strFile = Dir
Loop
End Sub
Again - the code DOES work, it's just that the Debug window keeps popping up and I can't figure out what the issue is. By the way, I had to "xx" out the actual directory.
Thank you for any help!
Try : this
It may help solving your problem, I had one of those sticky debug boxes too for no reason at all and this line helped me.
Edit: Here's the code from the website above which solves the problem described.
Adding this line in the beggining of one's code will do the trick.
Application.EnableCancelKey = xlDisabled

Resources