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
Related
The goal is to combine two functions or make them compatible with each other. There is errors when it comes to the part when the path of the chosen file is not refer to in the same manner as the path of the found file within the loop if available in the folder.
I get an error. See "HERE IS WHERE I GET THE ERROR" at
Dim closedBook As Workbook: Set closedBook = Workbooks.Open(sFilePath)
'main code that run is doing something like search for file within folder,
'loop and get the latest file and generates a path and name for next
'function which is to copy a sheet from the found file over to the main
'workbook and so.
'What I'm trying to to is to build a failsafe, lets say file is not pushed
'or placed whin this predestinated folder, then instead of doing nothing,
'dialog box opens up and files gets chosen instead.
Option Explicit
Sub ImportAndFormatData()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Const sFolderPath As String = "C:\Temp\"
'Search for newest file
Dim sFileName As String: sFileName = Dir(sFolderPath & "_pr11*.xlsx")
If Len(sFileName) = 0 Then Call OpenDialogBox
Dim cuDate As Date, sFileDate As Date, cuPath As String, sFilePath As String
Do Until Len(sFileName) = 0
cuPath = sFolderPath & sFileName
cuDate = FileDateTime(cuPath)
'Debug.Print "Current: " & cuDate & " " & cuPath ' print current
If cuDate > sFileDate Then
sFileDate = cuDate
sFilePath = cuPath
End If
sFileName = Dir
Loop
'Debug.Print "Result: " & sFileDate & " " & sFilePath ' print result
'Open newest file - HERE IS WHERE I GET THE ERROR
Dim closedBook As Workbook: Set closedBook = Workbooks.Open(sFilePath)
closedBook.Sheets("Analyse").Copy After:=ThisWorkbook.Sheets("PR11_P3")
closedBook.Close SaveChanges:=False
'code dose not end here but that part don't need to be included here since
'its just formatting
End Sub
In OpenDialogBox, I'm tying to enforce a specific title (only this file/report is correct source for the entire code or rather rest of the code).
See "GIVES ERROR DOSENT WORK" at
.Filters.Add "Excel filer", "_pr11*.xlsx?", 1
Sub OpenDialogBox()
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Title = "Välj valfri PR11"
.Filters.Add "Excel filer", "_pr11*.xlsx?", 1 'GIVES ERROR DOSENT WORK
.AllowMultiSelect = False
If .Show = True Then
Debug.Print .SelectedItems(1)
Debug.Print Dir(.SelectedItems(1))
End If
End With
End Sub
This combines both the Dir() and FileDialog approaches:
Sub ImportAndFormatData()
Dim fSelected As String, wb As Workbook
fSelected = InputFile()
If Len(fSelected) > 0 Then
Set wb = Workbooks.Open(fSelected)
wb.Sheets("Analyse").Copy After:=ThisWorkbook.Sheets("PR11_P3")
wb.Close False
End If
End Sub
Function InputFile() As String
Const SRC_FOLDER As String = "C:\Temp\"
Dim f, fSelected As String, latestDate As Date, fdt
f = Dir(SRC_FOLDER & "*_pr11*.xlsx") 'first check the configured folder for a match
If Len(f) > 0 Then
'found matching file at specified path: loop for the newest file
Do While Len(f) > 0
fdt = FileDateTime(SRC_FOLDER & f)
If fdt > latestDate Then
fSelected = SRC_FOLDER & f
latestDate = fdt
End If
f = Dir()
Loop
InputFile = fSelected
Else
'no match at specified path - allow user selection
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Title = "Välj valfri PR11"
.Filters.Add "Excel filer", "*.xlsx" 'filter only allows extension: no filename wildcards...
.AllowMultiSelect = False
If .Show Then InputFile = .SelectedItems(1)
End With
End If
End Function
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.
I have been trying to export NI TDMS files into my workbook and found a vba code posted by James Humphrey which is exactly what I am looking for. The issue is that whenever I try to run the code, it gives me a run time error which basically says that only the admin can execute the code.
Attached is snippet of the error and the code I used from James Humphrey's post.
Since I am not the admin, does anyone have a workaround for this issue? Thanks.
Sub ConvertTDMStoCSV()
'
' ConvertTDMS Macro
'
' Acts upon all .tdms files in a "source" directory,
' loading each one using the ExcelTDM Add In,
' deleting the first sheet and saving the
' remaining stream data as one .csv file
' in a "target" directory. Writes a list of
' the files converted in a new sheet.
'
Dim sourceDir As String, targetDir As String, fn As String, fnBase As String
Dim fso As Object, n As Long, resp As Integer, strNow As String, newSheet As Object
Dim tdmsAddIn As COMAddIn, importedWorkbook As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set tdmsAddIn = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
tdmsAddIn.Connect = True
Call tdmsAddIn.Object.Config.RootProperties.DeselectAll
Call tdmsAddIn.Object.Config.ChannelProperties.DeselectAll
tdmsAddIn.Object.Config.RootProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.GroupProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.ChannelProperties.SelectCustomProperties = False
'Choose TDMS Source Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Source Directory of TDMS Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
sourceDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(sourceDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, sourceDir
Exit Sub
End If
'Choose CSV Target Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Target Directory for CSV Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
targetDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(targetDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, targetDir
Exit Sub
End If
fn = Dir(sourceDir & "\*.tdms")
If fn = "" Then
MsgBox "No source TDMS files found.", vbInformation
Exit Sub
End If
resp = MsgBox("Begin conversion of TDMS files?" & vbCrLf & sourceDir & vbCrLf & "to" & vbCrLf & targetDir, vbYesNo, "Confirmation")
If resp = vbNo Then
MsgBox "Execution cancelled by user."
Exit Sub
End If
Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
strNow = WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss")
newSheet.Name = strNow
newSheet.Cells(1, 1).Value = "Files converted on " & strNow
newSheet.Cells(2, 1).Value = "TDMS Source Directory: " & sourceDir
newSheet.Cells(3, 1).Value = "CSV Target Directory: " & targetDir
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
n = 5
Do While fn <> ""
fnBase = fso.GetBaseName(fn)
On Error Resume Next
Call tdmsAddIn.Object.ImportFile(sourceDir & "\" & fn, True)
If Err Then
MsgBox Err.Description, vbCritical
Exit Sub
End If
Set importedWorkbook = ActiveWorkbook
Application.DisplayAlerts = False
importedWorkbook.Sheets(1).Delete
importedWorkbook.SaveAs Filename:=targetDir & "\" & fnBase & ".csv", FileFormat:=xlCSV
importedWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
newSheet.Cells(n, 1).Value = fnBase
n = n + 1
fn = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set fso = Nothing
Set newSheet = Nothing
Set importedWorkbook = Nothing
End Sub
Being an absolute VBA novice, I've pieced together some code that will run through an Excel sheet, checking everything's there, and then saving the sheet as a PDF file. I am, however, having some trouble with the saving part of the code. I keep getting the error "Compile error: Expected:=" to this line:
`Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,Quality:=xlQualityStandard,IncludeDocProperties:=True,IgnorePrintAreas:=False, OpenAfterPublish:=False)´
Am I just being a complete n00b here?
The whole thing looks like this:
Sub mcrSave()
Dim wsA As Worksheet
Dim wbA As Workbook
Dim strTime As String
Dim strName As String
Dim strPath As String
Dim strFile As String
Dim strPathFile As String
Dim myFile As Variant
On Error GoTo errHandler
'Check for mandatory fields
If Range("B3").Value = "" Then MsgBox ("Please fill in applicant")
Exit Sub
If Range("C1").Value = "" Then MsgBox ("Please fill in project title")
Exit Sub
If Range("H3").Value = "" Then MsgBox ("Please fill in date of application")
Exit Sub
If Range("C5").Value = "" Then MsgBox ("Please fill in expected cost")
Exit Sub
If Range("C7").Value = "" Then MsgBox ("Please fill in time schedule")
Exit Sub
If Range("B10").Value = "" Then MsgBox ("Please fill in project description")
Exit Sub
If Range("B18").Value = "" Then MsgBox ("Please fill in potential benefits")
Exit Sub
If Range("B26").Value = "" Then MsgBox ("Please fill in potential drawbacks")
Exit Sub
If Range("B34").Value = "" Then MsgBox ("Please fill in internal/external ressources")
Exit Sub
Set wbA = ActiveWorkbook
Set wsA = ActiveSheet
strTime = Format(Now(), "yyyymmdd\_hhmm")
'get active workbook folder, if saved
strPath = wbA.Path
If strPath = "" Then
strPath = Application.DefaultFilePath
End If
strPath = strPath & "\"
'replace spaces and periods in sheet name
strName = Replace(wsA.Name, " ", "")
strName = Replace(strName, ".", "_")
'create default name for savng file
strFile = strName & "_" & strTime & ".pdf"
strPathFile = strPath & strFile
'use can enter name and
' select folder for file
myFile = Application.GetSaveAsFilename(InitialFileName:=strPathFile, FileFilter:="PDF Files (*.pdf), *.pdf", Title:="Select Folder and FileName to save")
'export to PDF if a folder was selected
If myFile <> "False" Then
Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,Quality:=xlQualityStandard,IncludeDocProperties:=True,IgnorePrintAreas:=False, OpenAfterPublish:=False)
'confirmation message with file info
MsgBox "PDF file has been created: " & vbCrLf & myFile
End If
exitHandler:
Exit Sub
errHandler:
MsgBox "Could not create PDF file"
Resume exitHandler
End Sub
Syntax error. The correct syntax is either
call Wsa.ExportAsFixedFormat(Type:=xlTypePDF,Filename:=myFile,...)
or
Wsa.ExportAsFixedFormat Type:=xlTypePDF,Filename:=myFile,...
Change your Export command to the following:
Wsa.ExportAsFixedFormat Type:=xlTypePDF, Filename:=myFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Also, you need to change your Mandatory field checks so each looks like:
If Range("B3").Value = "" Then
MsgBox ("Please fill in applicant")
Exit Sub
End If
I have written a sub that should save worksheet 2 as a csv file with a time stamp in it. I let the user choose the file path with the get path sub, then when the user clicks 'okay' the program fails and says
run time error 9, subscript out of range.
Can you please help me figure out where/why my program is diong this?
Public Sub save()
Dim x As Integer
Dim FName As String
x = MsgBox("Are you sure?!?", vbYesNo, "Send File")
If x <> vbYes Then
GoTo Send_file_end:
End If
FName = get_path & "cambs_uplaoded_trades" & Format(Time, "hh mm ss") & ".csv"
ActiveWorkbook.Worksheets("sheet2").SaveAs Filename:=FName, FileFormat:=xlCSV
MsgBox "saved "
Send_file_end:
End Sub
here is my get path function
Function get_path() As String
Dim dlg As Variant
Set dlg = Application.FileDialog(msoFileDialogFolderPicker)
dlg.AllowMultiSelect = False
If dlg.Show <> -1 Then
get_path = ""
Else
get_path = dlg.SelectedItems(1) & "\"
End If
End Function
So i'll show you my solution just in case your interested:
Sheets("Sheet2").Activate
FName = get_path & "cambs_uplaoded_trades" & Format(Time, "hh mm ss") & ".csv"
ActiveWorkbook.Worksheets("Sheet2").SaveAs Filename:=FName, FileFormat:=xlCSV
MsgBox "saved "
ActiveSheet.Name = "Sheet2"
Sheets("Sheet1").Activate
So i activated sheet two before the name was changed, then saved it, then i changed the name of the active workshet back to sheet2.
thanks for you input!