records(0) = "='M:\My Documents\" & y3ar & " Project\Study\BLAB\" & y3ar & "\" & quarter & "\[" & y3ar & " Project 2 - Detailed Analysis " & quarter & ".xls]Image Admin Time'!$G$27"Public Sub CmdBrowse_Click()
Dim strPath As String
strPath = "c:\"
Call GetFolder(strPath)
Dim FileSpec As String
Dim FileArray() As Variant
FileSpec = strPath & "\*.xls"
'FileSpec = TBpath.Text & "\*.xlsx"
Call GetFileList(FileSpec, FileArray)
Stop' the filearray contain the filenames - not sure if you want then all or what
Erase FileArray
End Sub
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function
Function GetFileList(FileSpec As String, FileArray() As Variant) As Variant
Dim FileCount As Integer
Dim FileName As String
On Error GoTo NoFilesFound
FileCount = 0
FileName = Dir(FileSpec)
If FileName = "" Then GoTo NoFilesFound
' Loop until no more matching files are found
Do While FileName <> ""
FileCount = FileCount + 1
ReDim Preserve FileArray(1 To FileCount)
FileArray(FileCount) = FileName
FileName = Dir()
Loop
GetFileList = FileArray
Exit Function
' Error handler
NoFilesFound:
GetFileList = False
End Function
Public Sub Demo()
Const strPath As String = "C:\"
Const strFileName As String = "Test"
Dim strFileAndPath As String
strFileAndPath = strPath & Dir$(strPath & strFileName & ".xl*")
If Len(strFileAndPath) > Len(strPath) Then
Workbooks.Open Filename:=strFileAndPath
End If
End Sub FilesToOpen = Application.GetOpenFilename("Excel Files (*.xl*)," & "*.xl*", 1, "Select Excel File", "Open", MultiSelect:=False)
If FilesToOpen <> False Then MsgBox "Files selected " & FilesToOpen
