excel to csv using visual studio - excel

I'm trying to convert my excel file to csv using visual studio and I'm having trouble converting it. I have looped my code to go through .xls or .xlsx file in a folder and convert each one of them to csv. However, I'm having no results at all :(
Textbox1.Text is the folder selected and Textbox2.Text is the destination folder.
Anyone can help me on this?
Here is my code:
Dim xls As Excel.Application
Dim strFile As String, strPath As String
xls = New Excel.Application
strPath = TextBox1.Text
strFile = Dir(strPath & "*.xls")
While strFile <> ""
xls.Workbooks.Open(strPath & strFile)
xls.ActiveWorkbook.SaveAs(Filename:=Replace(TextBox2.Text & strFile, ".xls", ".csv"), FileFormat:=Microsoft.Office.Interop.Excel.XlFileFormat.xlTextMSDOS)
xls.Workbooks.Application.ActiveWorkbook.Close(SaveChanges:=False)
strFile = Dir()
End While
xls.Quit()

Put this inside a text file and save it as Excel2Csv.vbs. Save it inside a folder containing all your excel files. Then just simply drag your excel files onto this .vbs file.
'* Usage: Drop .xl* files on me to export each sheet as CSV
'* Global Settings and Variables
Dim gSkip
Set args = Wscript.Arguments
For Each sFilename In args
iErr = ExportExcelFileToCSV(sFilename)
' 0 for normal success
' 404 for file not found
' 10 for file skipped (or user abort if script returns 10)
Next
WScript.Quit(0)
Function ExportExcelFileToCSV(sFilename)
'* Settings
Dim oExcel, oFSO, oExcelFile
Set oExcel = CreateObject("Excel.Application")
Set oFSO = CreateObject("Scripting.FileSystemObject")
iCSV_Format = 6
'* Set Up
sExtension = oFSO.GetExtensionName(sFilename)
if sExtension = "" then
ExportExcelFileToCSV = 404
Exit Function
end if
sTest = Mid(sExtension,1,2) '* first 2 letters of the extension, vb's missing a Like operator
if not (sTest = "xl") then
if (PromptForSkip(sFilename,oExcel)) then
ExportExcelFileToCSV = 10
Exit Function
end if
End If
sAbsoluteSource = oFSO.GetAbsolutePathName(sFilename)
sAbsoluteDestination = Replace(sAbsoluteSource,sExtension,"{sheet}.csv")
'* Do Work
Set oExcelFile = oExcel.Workbooks.Open(sAbsoluteSource)
For Each oSheet in oExcelFile.Sheets
sThisDestination = Replace(sAbsoluteDestination,"{sheet}",oSheet.Name)
oExcelFile.Sheets(oSheet.Name).Select
oExcelFile.SaveAs sThisDestination, iCSV_Format
Next
'* Take Down
oExcelFile.Close False
oExcel.Quit
ExportExcelFileToCSV = 0
Exit Function
End Function
Function PromptForSkip(sFilename,oExcel)
if not (VarType(gSkip) = vbEmpty) then
PromptForSkip = gSkip
Exit Function
end if
Dim oFSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
sPrompt = vbCRLF & _
"A filename was received that doesn't appear to be an Excel Document." & vbCRLF & _
"Do you want to skip this and all other unrecognized files? (Will only prompt this once)" & vbCRLF & _
"" & vbCRLF & _
"Yes - Will skip all further files that don't have a .xl* extension" & vbCRLF & _
"No - Will pass the file to excel regardless of extension" & vbCRLF & _
"Cancel - Abort any further conversions and exit this script" & vbCRLF & _
"" & vbCRLF & _
"The unrecognized file was:" & vbCRLF & _
sFilename & vbCRLF & _
"" & vbCRLF & _
"The path returned by the system was:" & vbCRLF & _
oFSO.GetAbsolutePathName(sFilename) & vbCRLF
sTitle = "Unrecognized File Type Encountered"
sResponse = MsgBox (sPrompt,vbYesNoCancel,sTitle)
Select Case sResponse
Case vbYes
gSkip = True
Case vbNo
gSkip = False
Case vbCancel
oExcel.Quit
WScript.Quit(10) '* 10 Is the error code I use to indicate there was a user abort (1 because wasn't successful, + 0 because the user chose to exit)
End Select
PromptForSkip = gSkip
Exit Function
End Function

Related

Can you create a PDF and have a target path such as i have below?

Ok, So i am trying to create a PDf and place it into a a folder that is named after cell E10 in which is side a folder of B18. I am getting a "Compile Error block If Without End If" I have tried both end and exit statements with no luck.
Function Dispatch_PDF() As Boolean ' Copies sheets into new PDF file for e-mailing
Dim Thissheet As String, ThisFile As String, PathName As String
Dim SvAs As String
Dim Tmp As String
Dim FldName As String
' 1. Create the name you want to search for before starting the search
' 2. don't refer to cells by their range names (too cumbersome)
FldName = Cells(10, 5).Value ' actually, it's Cells(10, 5)
Debug.Print FldName ' check the name
If Len(FldName) Then
Tmp = Cells(18, 2).Value
If Len(Tmp) Then
FldName = Tmp & "\" & FldName ' observe how to add the path separator
Debug.Print FldName ' check the name
FldName = ActiveWorkbook.path & "\DISPATCHED WORK ORDERS\" & FldName
Debug.Print FldName
Application.ScreenUpdating = False
' Get File Save Name
Thissheet = ActiveSheet.Name
ThisFile = ActiveWorkbook.Name
PathName = ActiveWorkbook.path
SvAs = PathName & "\DISPATCHED WORK ORDERS\" & FldName & Range("E10").Value & ".pdf"
'Set Print Quality
On Error Resume Next
ActiveSheet.PageSetup.PrintQuality = 600
Err.Clear
On Error GoTo 0
' Instruct user how to send
On Error GoTo RefLibError
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=SvAs, Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintAreas:=False, OpenAfterPublish:=True
On Error GoTo 0
SaveOnly:
MsgBox "A copy of this sheet has been successfully saved as a .pdf file: " & Chr(13) & Chr(13) & SvAs & _
"Review the .pdf document. If the document does NOT look good, adjust your printing parameters, and try again."
Dispatch_PDF = True
GoTo EndMacro
RefLibError:
MsgBox "Unable to save as PDF. Reference library not found."
Dispatch_PDF = False
EndMacro:
End Function
Any Suggestions?

How can I password protect the zip folder in VBA?

I want to password protect the zip folder not the files in zip folder using VBA.
for example: if there is folder test.zip and there is file test.xlsx in it. I want to have a password on folder test.zip. Can someone help? Will be highly appreciated. Thanks
This procedure accepts an argument named NewFolder, which represents the folder to which the user is trying to switch. If this folder’s name is Confidential, the procedure asks the user to enter the password. If the password doesn’t match, the Cancel argument is set to True, which means the folder isn’t displayed.
Hope this will help you:
Sub zip_activeworkbook()
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
If ActiveWorkbook Is Nothing Then Exit Sub
DefPath = ActiveWorkbook.Path
If Len(DefPath) = 0 Then
msgbox "Please Save activeworkbook before zipping" & Space(12), vbInformation, "zipping"
Exit Sub
End If
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
'Create date/time string and the temporary xls and zip file name
strDate = Format(Now, " dd-mmm-yy h-mm-ss")
FileNameZip = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".zip"
FileNameXls = DefPath & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & strDate & ".xls"
If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
'Make copy of the activeworkbook
ActiveWorkbook.SaveCopyAs FileNameXls
'Create empty Zip File
newzip (FileNameZip)
'Copy the file in the compressed folder
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(FileNameZip).CopyHere FileNameXls
'Keep script waiting until Compressing is done
On Error Resume Next
Do Until oApp.Namespace(FileNameZip).items.Count = 1
Application.Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
'Delete the temporary xls file
Kill FileNameXls
msgbox "completed zipped : " & vbNewLine & FileNameZip, vbInformation, "zipping"
Else
msgbox "FileNameZip or/and FileNameXls exist", vbInformation, "zipping"
End If
End Sub
Private Sub newzip(sPath)
'Create empty Zip File
'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
You may find my version easier to use and understand. Here is the macro code along with an example of using it. The password is optional.
Private Declare Function ShellExecute _
Lib "Shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Sub ZipFile(FileName As String, Optional ByVal Password As String)
Dim CmdLine As String
Dim Ext As Long
Dim FilePath As String
Dim RetVal As Long
Dim Path As Long
Dim ZipName As String
' If no path is specified use the current directory
Path = InStrRev(FileName, "\")
FilePath = IIf(Path = 0, CurDir & "\", "")
' Check if file exists
If Dir(FilePath & FileName) = "" Then
MsgBox "File Not Found" & vbCrLf & " " & FilePath & FileName
Exit Sub
End If
' Name for the zip archive
Ext = InStrRev(FileName, ".")
ZipName = FilePath & IIf(Ext = 0, FileName & ".zip", Left(FileName, Ext) & "zip")
' Command line string - file names must include quotes
If Password = "" Then
CmdLine = "-min -a -en " & Chr$(34) & ZipName & Chr$(34) & " " _
& Chr$(34) & FileName & Chr$(34)
Else
CmdLine = "-min -a -en -s" & Chr$(34) & Password & Chr$(34) _
& " " & Chr$(34) & ZipName & Chr$(34) & " " _
& Chr$(34) & FileName & Chr$(34)
End If
' Command line String to Unzip a file
'CmdLine = "-min -e " & Chr$(34) & ZipFileName & Chr$(34) & " " _
' & FolderPath
' Zip the file and save it in the archive
RetVal = ShellExecute(0&, "", "WinZip32.exe", CmdLine, FilePath, 1&)
' Check for Errors are from 0 to 32
If RetVal <= 32 Then
Select Case RetVal
Case 2 'SE_ERR_FNF
Msg = "File not found"
Case 3 'SE_ERR_PNF
Msg = "Path not found"
Case 5 'SE_ERR_ACCESSDENIED
Msg = "Access denied"
Case 8 'SE_ERR_OOM
Msg = "Out of memory"
Case 32 'SE_ERR_DLLNOTFOUND
Msg = "DLL not found"
Case 26 'SE_ERR_SHARE
Msg = "A sharing violation occurred"
Case 27 'SE_ERR_ASSOCINCOMPLETE
Msg = "Incomplete or invalid file association"
Case 28 'SE_ERR_DDETIMEOUT
Msg = "DDE Time out"
Case 29 'SE_ERR_DDEFAIL
Msg = "DDE transaction failed"
Case 30 'SE_ERR_DDEBUSY
Msg = "DDE busy"
Case 31 'SE_ERR_NOASSOC
Msg = "Default Email not configured"
Case 11 'ERROR_BAD_FORMAT
Msg = "Invalid EXE file or error in EXE image"
Case Else
Msg = "Unknown error"
End Select
Msg = "File Not Zipped - " & Msg & vbCrLf & "Error " & RetVal
MsgBox Msg, vbExclamation + vbOKOnly
End If
Example of using the macro:
Sub ZipTest()
ZipFile "C:\PF Credits.xls", Password:="123"
End Sub

Search for a string and move files containing string from source folder to destination folder

I have large number of .csv files in a folder and each file has few separation codes in them. Separation code usually will be 5 digit code eg: B82A6.
I have to copy files with a certain separation code and move them to a destination folder.
I am new to VBA. I've been searching for code to modify it to my use.
Sub Test()
Dim R As Range, r1 As Range
Dim SourcePath As String, DestPath As String, SeperationCode As String
SourcePath = "C:\Users\hr315e\Downloads\Nov_03_2019\"
DestPath = "C:\Users\hr315e\Downloads\Target\"
Set r1 = Range("A1", Range("A" & Rows.Count).End(xlUp))
For Each R In r1
SeperationCode = Dir(SourcePath & R)
Do While SeperationCode <> ""
If Application.CountIf(r1, SeperationCode) Then
FileCopy SourcePath & SeperationCode, DestPath & SeperationCode
R.Offset(0, 1).Value = SeperationCode
Else
MsgBox "Bad file: " & SeperationCode & " ==>" & SeperationCode & "<== "
End If
SeperationCode = Dir(SourcePath & "B82A6" & R.Value & "B82A6")
Loop
Next
End Sub
So, here's the code that should work for you.
As you can see, this is a version of code which I linked to you with small updates:
Sub GoThroughFilesAndCopy()
Dim BrowseFolder As String, DestinationFolder As String
Dim FileItem As Object
Dim oFolder As Object
Dim FSO As Object
Dim TempFileName As String
Dim CheckCode As String
Application.ScreenUpdating = False
' selecting the folder with files
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the folder with files"
.Show
On Error Resume Next
Err.Clear
BrowseFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
' or you may hardcode it (data from your post):
'BrowseFolder = "C:\Users\hr315e\Downloads\Nov_03_2019\"
' selecting the destination folder
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Select the the destination folder"
.Show
On Error Resume Next
Err.Clear
DestinationFolder = .SelectedItems(1)
If Err.Number <> 0 Then
MsgBox "You didn't select anything!"
Application.ScreenUpdating = True
Exit Sub
End If
On Error GoTo 0
End With
' or you may hardcode it (data from your post):
'DestinationFolder = "C:\Users\hr315e\Downloads\Target\"
CheckCode = "Some string" ' this is you check code
Set FSO = CreateObject("Scripting.FileSystemObject") ' creating filesystem object
Set oFolder = FSO.getfolder(BrowseFolder) ' creating folder object
For Each FileItem In oFolder.Files 'looking through each file in selected forlder
TempFileName = ""
If UCase(FileItem.Name) Like "*.CSV*" Then 'try opening only .csv files
TempFileName = BrowseFolder & Application.PathSeparator & FileItem.Name ' getting the full name of the file (with full path)
If CheckTheFile(TempFileName, CheckCode) Then ' if the file passes the checking function
If Dir(DestinationFolder & Application.PathSeparator & FileItem.Name) = "" Then 'if the file doesn't exist in destination folder
FileCopy Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name ' it is copied to destination
Else ' otherwise, there are to options how to deal with it further
'uncomment the part you need below:
' this will Overwrite existing file
'FSO.CopyFile Source:=TempFileName, Destination:=DestinationFolder & Application.PathSeparator & FileItem.Name
' this will get new name for file and save it as copy
'FileCopy Source:=TempFileName, Destination:=GetNewDestinationName(FileItem.Name, DestinationFolder)
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
'////////////////////////////////////////////////////////////////////////
Function CheckTheFile(File As String, Check As String) As Boolean
Dim TestLine As String
Dim TestCondition As String
TestCondition = "*" & Check & "*" ' this is needed to look for specific text in the file, refer to Like operator fro details
CheckTheFile = False
Open File For Input As #1 ' open file to read it line by line
Do While Not EOF(1)
Line Input #1, TestLine ' put each line of the text to variable to be able to check it
If TestLine Like TestCondition Then ' if the line meets the condition
CheckTheFile = True ' then function gets True value, no need to check other lines as main condition is met
Close #1 ' don't forget to close the file, beacuse it will be still opened in background
Exit Function ' exit the loop and function
End If
Loop
Close #1 ' if condiotion is not found in file just close the file, beacuse it will be still opened in background
End Function
'////////////////////////////////////////////////////////////////////////
Function GetNewDestinationName(File As String, Destination As String) As String
Dim i As Integer: i = 1
Do Until Dir(Destination & Application.PathSeparator & "Copy (" & i & ") " & File) = "" ' if Dir(FilePath) returns "" (empty string) it means that the file does not exists, so can save new file with this name
i = i + 1 ' incrementing counter untill get a unique name
Loop
GetNewDestinationName = Destination & Application.PathSeparator & "Copy (" & i & ") " & File ' return new file name
End Function
Basically, there is one sub, which is mostly copy-paste from linked topic, and two simple functions.

VBA Macro does nothing after run, gives no errors (macos)

This is my first question on this platform, so please forgive any mistake I might make.
I have a couple of excel workbooks that I would like to make multiple exact changes to exact sheets and exact cells in all of them, but they are way too many to do individually.
I recorded all the changes I am to make in a macro using one of the workbooks;
Sub Macro1()
Range("W4:X4").Select
ActiveCell.FormulaR1C1 = "OFF -PEAK GEM(MW)"
Range("J33:M33").Select
ActiveCell.FormulaR1C1 = "Hz"
Range("B33:I33").Select
ActiveCell.FormulaR1C1 = "DETAILS"
Range("R34:X34").Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
Range("R35:X35").Select
Selection.Cut
Range("R34").Select
ActiveSheet.Paste
Range("K68:L123").Select
Selection.Delete Shift:=xlToLeft
Range("K68:L68").Select
ActiveCell.FormulaR1C1 = "UNITS ON BAR"
Range("V178").Select
ActiveCell.FormulaR1C1 = "EXPECTED RESERVE"
Range("V179:V182").Select
End Sub
I ran this macro in another different unmodified workbook and it worked perfectly.
I'm quite new to using VBA, but I was able to find a block of code online that makes a change in multiple excel files in a specified directory;
Sub ChangeFiles()
Dim MyPath As String
Dim MyFile As String
Dim dirName As String
Dim wks As Worksheet
' Change directory path as desired
dirName = "c:\myfiles\"
MyPath = dirName & "*.xlsx"
MyFile = Dir(MyPath)
If MyFile > "" Then MyFile = dirName & MyFile
Do While MyFile <> ""
If Len(MyFile) = 0 Then Exit Do
Workbooks.Open MyFile
With ActiveWorkbook
For Each wks In .Worksheets
' Specify the change to make
wks.Range("A1").Value = "A1 Changed"
Next
End With
ActiveWorkbook.Close SaveChanges:=True
MyFile = Dir
If MyFile > "" Then MyFile = dirName & MyFile
Loop
End Sub
I edited it to fit my needs like so;
Sub ChangeFiles()
Dim MyPath As String
Dim MyFile As String
Dim dirName As String
Dim wks As Worksheet
Set wks = ActiveWorkbook.Worksheets("SHEET X")
' Change directory path as desired
dirName = "/Users/Account/Desktop/Directory 1/Directory 2/"
MyPath = dirName & "*.xls"
MyFile = Dir(MyPath)
If MyFile > "" Then MyFile = dirName & MyFile
Do While MyFile <> ""
If Len(MyFile) = 0 Then Exit Do
Workbooks.Open MyFile
With ActiveWorkbook
For Each wks In ActiveWorkbook.Worksheets
' Specify the change to make
wks.Range("W4:X4").Select
ActiveCell.FormulaR1C1 = "OFF -PEAK GEM(MW)"
wks.Range("J33:M33").Select
ActiveCell.FormulaR1C1 = "Hz"
wks.Range("B33:I33").Select
ActiveCell.FormulaR1C1 = "DETAILS"
wks.Range("R34:X34").Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
wks.Range("R35:X35").Select
Selection.Cut
wks.Range("R34").Select
ActiveSheet.Paste
wks.Range("K68:L123").Select
Selection.Delete Shift:=xlToLeft
wks.Range("K68:L68").Select
ActiveCell.FormulaR1C1 = "UNITS ON BAR"
wks.Range("V178").Select
ActiveCell.FormulaR1C1 = "EXPECTED RESERVE"
wks.Range("V179:V182").Select
Next
End With
ActiveWorkbook.Close SaveChanges:=True
MyFile = Dir
If MyFile > "" Then MyFile = dirName & MyFile
Loop
End Sub
I ran it and it did nothing and returned no error. I'm really at my wits' end here and I would really appreciate any help.
P.S I'm a mac user
Well, 120 simultaneous open tabs(no joke, I counted 😂) and two sleepless nights later, I finally found a solution. NOTE: THIS WORKS ON MAC ONLY, apparently I think Dir doesn't work on Mac, thanks to #Jeeped for pointing that out, so for other Mac users with my issue, this is what I did:
Option Explicit
'Important: this Dim line must be at the top of your module
Dim dirName As String
Sub ChangeFiles()
Dim MySplit As Variant
Dim FileIndirName As Long
Dim wks As Worksheet
'Clear dirName to be sure that it not return old info if no files are found
dirName = ""
Call GetFilesOnMacWithOrWithoutSubfolders(Level:=1, ExtChoice:=1, FileFilterOption:=0, FileNameFilterStr:="SearchString")
If dirName <> "" Then
With Application
.ScreenUpdating = False
End With
MySplit = Split(dirName, Chr(13))
For FileIndirName = LBound(MySplit) To UBound(MySplit)
Workbooks.Open (MySplit(FileIndirName))
Set wks = ActiveWorkbook.Worksheets("SHEET X")
With wks
.Range("W4:X4") = "OFF -PEAK GEM(MW)"
.Range("J33:M33") = "Hz"
.Range("B33:I33") = "DETAILS"
.Range("R34:X34").EntireRow.Insert Shift:=xlShiftDown
.Range("R35:X35").Cut Destination:=Range("R34")
.Range("K68:L123").Delete Shift:=xlToLeft
.Range("K68:L68") = "UNITS ON BAR"
.Range("V178") = "EXPECTED RESERVE"
End With
ActiveWorkbook.Close SaveChanges:=True
Next FileIndirName
With Application
.ScreenUpdating = True
End With
Else
MsgBox "Sorry no files that match your criteria, A 0 files result can be due to Apple sandboxing: Try using the Browse button to re-select the folder."
With Application
.ScreenUpdating = True
End With
End If
MsgBox "Done!"
End Sub
'*******Function that do all the work that will be called by the macro*********
Function GetFilesOnMacWithOrWithoutSubfolders(Level As Long, ExtChoice As Long, _
FileFilterOption As Long, FileNameFilterStr As String)
'Ron de Bruin,Version 4.0: 27 Sept 2015
'http://www.rondebruin.nl/mac.htm
'Thanks to DJ Bazzie Wazzie and Nigel Garvey(posters on MacScripter)
Dim ScriptToRun As String
Dim folderPath As String
Dim FileNameFilter As String
Dim Extensions As String
On Error Resume Next
folderPath = MacScript("choose folder as string")
If folderPath = "" Then Exit Function
On Error GoTo 0
Select Case ExtChoice
Case 0: Extensions = "(xls|xlsx|xlsm|xlsb)" 'xls, xlsx , xlsm, xlsb
Case 1: Extensions = "xls" 'Only xls
Case 2: Extensions = "xlsx" 'Only xlsx
Case 3: Extensions = "xlsm" 'Only xlsm
Case 4: Extensions = "xlsb" 'Only xlsb
Case 5: Extensions = "csv" 'Only csv
Case 6: Extensions = "txt" 'Only txt
Case 7: Extensions = ".*" 'All files with extension, use *.* for everything
Case 8: Extensions = "(xlsx|xlsm|xlsb)" 'xlsx, xlsm , xlsb
Case 9: Extensions = "(csv|txt)" 'csv and txt files
'You can add more filter options if you want,
End Select
Select Case FileFilterOption
Case 0: FileNameFilter = "'.*/[^~][^/]*\\." & Extensions & "$' " 'No Filter
Case 1: FileNameFilter = "'.*/" & FileNameFilterStr & "[^~][^/]*\\." & Extensions & "$' " 'Begins with
Case 2: FileNameFilter = "'.*/[^~][^/]*" & FileNameFilterStr & "\\." & Extensions & "$' " ' Ends With
Case 3: FileNameFilter = "'.*/([^~][^/]*" & FileNameFilterStr & "[^/]*|" & FileNameFilterStr & "[^/]*)\\." & Extensions & "$' " 'Contains
End Select
folderPath = MacScript("tell text 1 thru -2 of " & Chr(34) & folderPath & _
Chr(34) & " to return quoted form of it's POSIX Path")
folderPath = Replace(folderPath, "'\''", "'\\''")
If Val(Application.Version) < 15 Then
ScriptToRun = ScriptToRun & "set foundPaths to paragraphs of (do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """)" & Chr(13)
ScriptToRun = ScriptToRun & "repeat with thisPath in foundPaths" & Chr(13)
ScriptToRun = ScriptToRun & "set thisPath's contents to (POSIX file thisPath) as text" & Chr(13)
ScriptToRun = ScriptToRun & "end repeat" & Chr(13)
ScriptToRun = ScriptToRun & "set astid to AppleScript's text item delimiters" & Chr(13)
ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to return" & Chr(13)
ScriptToRun = ScriptToRun & "set foundPaths to foundPaths as text" & Chr(13)
ScriptToRun = ScriptToRun & "set AppleScript's text item delimiters to astid" & Chr(13)
ScriptToRun = ScriptToRun & "foundPaths"
Else
ScriptToRun = ScriptToRun & "do shell script """ & "find -E " & _
folderPath & " -iregex " & FileNameFilter & "-maxdepth " & _
Level & """ "
End If
On Error Resume Next
dirName = MacScript(ScriptToRun)
On Error GoTo 0
End Function
By the way, #urdearboy thanks for your suggestion, it really helped, although I had problems with the .PasteSpecial, I still found a workaround.
For anyone wondering, what the code does when you run it is it basically brings up a dialog box asking you to chose your desired folder, when you do, it finds files with the .xls extension (you can change that) and performs the change in all .xls files in that folder.
Thanks to everyone who commented on this post. ^_^
Note: this is not meant to be a solution and will be deleted. Just wanted to make a suggestion for OP
You should update your excel operations as follows.
This Link will show you alternatives to the .Select method.
With wks
.Range("W4:X4") = "OFF -PEAK GEM(MW)"
.Range("J33:M33") = "Hz"
.Range("B33:I33") = "DETAILS"
.Range("R34:X34").Insert , CopyOrigin:=xlFormatFromLeftOrAbove
.Range("R35:X35").Copy
.Range("R35:x35").ClearContents
.Range("R34").PasteSpecial
.Range("K68:L123").Delete Shift:=xlToLeft
.Range("K68:L68") = "UNITS ON BAR"
.Range("V178") = "EXPECTED RESERVE"
End With

Excel VBA continues to 'Open File' even after Cancel

Okay here it is. I've done a bunch of coding in the last 3 or 4 months, learned a lot, BUT, I can't figure out why this code STILL opens a file when I hit cancel at the end once the popup window comes up showing my filtered filenames. Any advice would be highly appreciated.
Sub OpenByPartialName()
' Returns popup window with only filtered filenames matching
' Partial Filename input
Dim WB As Workbook
Dim Ans As String
Dim MyFile As String
Dim path As String
' Folder Path Name for Forms
path = ("S:\Forms Folder\")
Ans = InputBox("Enter Partial filename Filter", "Open File With Partial Name Filter")
MyFile = Dir("S:\Forms Folder\" & "*" & Ans & "*.xls")
MyFilter = path & "*" & Ans & "*.xls"
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = MyFilter
If .Show = 1 Then
MyFile = .SelectedItems(1)
End If
End With
On Error Resume Next
Set WB = Workbooks.Open(MyFile)
End Sub
That would be a dirty hack, but if you had an Else branch here:
If .Show = 1 Then
MyFile = .SelectedItems(1)
Else
MyFile = vbNullString
End If
...the code that actually opens the file could verify whether MyFile is empty or not before trying:
On Error Resume Next
If MyFile <> vbNullString Then Set WB = Workbooks.Open(MyFile)
That said I think you should be handling at least error 53 ("file not found") here, instead of just shoving all errors under the carpet.
Also the WB reference isn't used. Perhaps the Sub should be a Function that returns the opened workbook, or Nothing if opening fails?
This is what I use to select a directory. If the function returns an empty string, I don't try to open the file.
Private Function FolderPicker() As String
'*******************************************
' returns directory path to be printed to
' does not allow multiple selections,
' so returning the first item in selected
' items is sufficient.
'
' returns empty string On Error or if the
' user cancels
'********************************************
On Error GoTo ErrHandler
Const DefaultDirectory As String = "C:Path\to\default\directory\"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Title = "Choose Directory to Print to"
.InitialFileName = DefaultDirectory
.InitialView = msoFileDialogViewSmallIcons
If .Show <> -1 Then
FolderPicker = vbNullString
Else
FolderPicker = .SelectedItems(1)
End If
End With
Exit Function
ErrExit:
FolderPicker = vbNullString
Exit Function
ErrHandler:
MsgBox "Unexpected Error: " & Err.number & vbCrLf & "Source: " & Err.Source & _
"Description: " & Err.Description, vbCritical, "ERROR!"
Resume ErrExit
End Function
So, you would call it like this.
MyFile = FolderPicker
If MyFile <> vbNullString Then
Set WB = Workbooks.Open(MyFile)
End If
Much blood, sweat and tears later (Serious web surfing, cobbling code together and retesting) I have found an answer that works without any problems for pressing 'Cancel' at any point.
Sub OpenAuditPartialName()
' Returns popup window with only filtered
' filenames matching input criteria.
' Filenames are saved from another code that uses 3 variables to generate a _
' filename 'Filename part1_Filename part2_Filename part3 Forms.xls'
Dim WB As Workbook
Dim Ans As String
Dim MyFile As String
Dim path As String
' Folder path for Forms
path = ("S:\Forms Folder\")
Ans = InputBox("Enter any part of the filename to search by." & vbCrLf & vbCrLf & _
"Full or Partial information is OK." & vbCrLf & vbCrLf & "Filename part1" _
& vbCrLf & "Filename part2" & vbCrLf & "Filename part3", "Enter Partial Filename Filter")
' Exits on 'Cancel' as it should
If Ans = "" Then
Exit Sub
End If
MyFile = Dir(path & "*" & Ans & "*.xls")
MyFilter = path & "*" & Ans & "*.xls"
'*******************************************
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = MyFilter
' Now accepts the 'Cancel' instead of continuing to open the first file
' in the filtered list when pressed
If .Show = 0 Then
ElseIf Len(Ans) Then
MyFile = .SelectedItems(1)
On Error Resume Next
Set WB = Workbooks.Open(MyFile)
Else
Exit Sub
End If
'*******************************************
End With
End Sub

Resources