Free Microsoft Excel 2013
Quick Reference
Free Microsoft 2013 Quick Reference Guide

Free Microsoft Excel 2013 Quick Reference

Using Application.FileDialog(msoFileDialogFolderPicker)

I am trying to use Application.FileDialog(msoFileDialogFolderPicker)
to get a folder and run a macro on each file in that folder. I was using
this approach befo
folderspec = Application.InputBox(prompt:="Input Folder Path", Title:="Get
Folder", Type:=2)
but it requires someone to copy and paste the folder path. But I want to
use a different approach where the filedialog opens and you can pick the
folder directly. I know Application.FileDialog(msoFileDialogFolderPicker) is
what is needed but I can figure out what next. This is what I have, and it's
giving me an error

folderspec = Application.FileDialog(msoFileDialogFolderPicker)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getFolder(folderspec)
Set fc = f.Files
For Each f1 In fc
s = f1.Path
Workbooks.Open Filename:=s, UpdateLinks:=0
Thanks for the help.


Post your answer or comment

comments powered by Disqus
My code is below. Very simple, the users to select a directory and I'd like
to pick up where this has been previously set. This all works, it picksup the
directory, it changes the CurDir and msgbox it back all fine. Then the next
stage is the file browse dialog and is using somewhere else again ! How can I
set or control where the FileDialog(msoFileDialogFolderPicker) starts the
default view from ?
TIA

Public OldDir As String
Public ArchiveDir As String

Sub UseFileDialogOpen()

'Pick Up Current Directory
OldDir = CurDir

'Pick up archive directory
ArchiveDir = Sheets("Files").Range("B9").Value
'ArchiveDir = "C:windows"

'Test Archive Directory exists
If Dir(ArchiveDir, vbDirectory) <> "" Then
'If ArchiveDir Found
ChDir ArchiveDir
MsgBox CurDir
End If

' Open the file dialog
Set BrowseFolder = Application.FileDialog(msoFileDialogFolderPicker)
With BrowseFolder
.Show
If BrowseFolder.SelectedItems.Count > 0 Then
Var = .SelectedItems(1)
End If
End With

MsgBox Var

End Sub

I've written a module in Excel 2002 that uses Application.FileDialog(msoFileDialogSaveAs) to allow the user to pick a valid pathname on their local hard drive and choose a filename. This pathname and filename is then stored as a variable and passed to the rest of the routine.
When i come to try this in Excel 2000 (more than 50% of the users use 2000) i have found that Application.FileDialog is not present. Does anyone know how i can achieve the same in Excel 2000? I have included some of the code used below. Thanks in advance.


	VB:
	
 Office.FileDialog 
Dim varFile As Variant 
 
Set fDialog = Application.FileDialog(msoFileDialogSaveAs) 
 
With fDialog 
    .AllowMultiSelect = False 
    .Title = "Select File Location to Export csv :" 
    .InitialFileName = "Diabetes_Audit" 
     
    If .Show = True Then 
        For Each varFile In .SelectedItems 
            response = MsgBox("You chose to save to: " & vbCrLf & vbCrLf & varFile, _ 
            vbInformation + vbOKOnly, "Chosen File Name") 
            FileNum = FreeFile() 
             
            On Error Resume Next 
             
            Open varFile For Output As #FileNum 
             
            If Err  0 Then 
                MsgBox "Cannot open filename, " & varFile & "," _ 
                & Chr(10) & "you will need to specify a different directory structure." _ 
                & Chr(10) & "Please run the macro again." 
                End 
            End If 
             
             
            On Error Goto 0 
        Next 
    End If 
     
End With 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I compiled a working dll with office XP developer (code below). It does the
following:
1) loads a folder picker dialog box.
2) I choose a folder and save it to a variable
3) when "OPEN" is clicked msgbox is generated
I am call this function via a custom menu item
Problem/Issue occurs when the if statement is being executed, Excel
hangs/stops responding. I think it has to do with the dialog being/not being
modal but there does not seem to be any way to change that. Also when the
diabox is ls loaded it does not get the focus. What is up with that?
Thanks in advance

Private Sub message()
MsgBox "Can you read this"
Dim DefaultDir As String
Set folder = Application.FileDialog(msoFileDialogFolderPicker)
If folder.Show <> 0 Then
DefaultDir = folder.SelectedItems.Item(1) & ""
MsgBox "Default Dir is " & DefaultDir
ElseIf folder.Show = 0 Then
MsgBox "cancel button selected."
End If
End Sub

Hi,

I am using application.FileDialog to make the user select a file, when clicking a button. Now, I have tested, what happens, when I click on "Abort", instead of selecting a file and clicking "OK". An error message appears, because no file is selected.
So my question is: How do I state in my code, what is supposed to happen, when the User Clicks on "abort" (I want the whole Sub to be aborted in this case)

Thanks in advance!

How do I use this code to loop through all the files in a folder and perform
some action on each

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & ""
.Title = "Please select the location of the RFDS folder"
.Show
For Each vrtSelectedItem In .SelectedItems
myFile= vrtSelectedItem
If .SelectedItems.Count = 0 Then
MsgBox "Canceled"
Else
MsgBox myFile
End If
Next vrtSelectedItem
End With

What I am am trying to do is, select a folder and transfer all the
information on each file in that folder to a worksheet. The code above gets
me to the folder but I need to figure out how to now tell the code to open
each file in that folder so that I can perform the neccessary action on the
file, close the file and then open the next file in the folder.
Thanks.

Hi All,

I am using the code below to get file names using msoFileDialogFolderPicker. Is there any way I can unload this file path into a cell (e.g. cell $C$14) or a named range (e.g. DirName)?

Thanks!

Sub
GetFileNames()
     
    Dim xRow As Long
    Dim xDirect$, xFname$, InitialFoldr$, xLocation
    Range("B11").Select
     
    InitialFoldr$ = "" '<<< Startup folder to begin searching from
     
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & ""
        .Title = "Please select a folder to list Files from"
        .InitialFileName = InitialFoldr$
        .Show
        
        If .SelectedItems.Count <> 0 Then
            xDirect$ = .SelectedItems(1) & "" & "*.xls"
            xFname$ = Dir(xDirect$, 7)
            Do While xFname$ <> ""
                ActiveCell.Offset(xRow) = xFname$
                xRow = xRow + 1
                xFname$ = Dir
            Loop
        End If
    End With

End Sub


How to use this code in excel 2000?

See..


	VB:
	
 FileDialog[/FONT][/COLOR] 
[COLOR=#333333][FONT=Lucida Grande]Dim arquivo As String[/FONT][/COLOR] 
[COLOR=#333333][FONT=Lucida Grande]Set fd = Application.FileDialog(msoFileDialogFolderPicker)[/FONT][/COLOR] 
[COLOR=#333333][FONT=Lucida Grande]If fd.Show = -1 Then[/FONT][/COLOR] 
[COLOR=#333333][FONT=Lucida Grande]arquivo = fd.SelectedItems(1)[/FONT][/COLOR] 
[COLOR=#333333][FONT=Lucida Grande]MsgBox "A pasta selecionada é " & arquivo[/FONT][/COLOR] 
[COLOR=#333333][FONT=Lucida Grande]Else: arquivo = ""[/FONT][/COLOR] 
[COLOR=#333333][FONT=Lucida Grande]End[/FONT][/COLOR] 
[COLOR=#333333][FONT=Lucida Grande]End If[/FONT][/COLOR] 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hi All,

Firstly, I'm a beginner at VBA but I seem to get by on integrating already made codes and getting things to work at the moment.

I have a specific solution I require but haven't managed to figure out exactly how to do this effectively - it would be great if you could help?

Requirements as follows:

I have a single Excel workbook which will be used by several users/machines and I want to have a macro which:
1 - Asks user where the import files are located in a browser type window (all will be in same folder so this only needs to be done once, but the overall location of this folder may change depending on the user hence the need to ask this)

================
Another option would be to encourage the user to always keep the import folder in the same directory where the Excel file is saved but then I would prefer the code to link to /IMPORT from the relative Excel saved location rather than C/Username/Documents/IMPORT for example as multiple users will be working on this s/sheet.
================

2 - Import each specific file to the correct worksheet (detailed below), clearing existing data and pasting the new import data from Cell D5 onwards (I have data which cannot be removed in columns A-C and rows 1-4)

3 - Save the workbook.

To clarify, I want to import the following files into the worksheets indicated. The filenames will not change and they all be located in the same folder.
Textfile1.txt --> Worksheet1
Textfile2.txt --> Worksheet2
Textfile3.txt --> Worksheet3
CSVFile1.csv --> Worksheet4
CSVFile2.csv --> Worksheet5
CSVFile3.csv --> Worksheet6

I have the code for choosing the folder, but this code then imports all text files contained within this folder to 1 worksheet. I want to extend the ability of this to work for the above.

Any help on this would be much appreciated.

Thanks,

Rav

p.s. this isn't my own code, it was posted from someone else on here (http://www.ozgrid.com/forum/showthre...t=78498&page=1)


	VB:
	
 GetFiles_Click() 
    test 
End Sub 
 
Function GetFolder() As String 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
        .Title = "Select a Folder" 
        .AllowMultiSelect = False 
        .InitialFileName = Application.DefaultFilePath 
        If .Show  -1 Then Goto NextCode 
        sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 
Sub test() 
    Dim myDir As String, fn As String, ff As Integer, txt As String, a() 
    Dim x, i As Long, n As Long, b(), t As Long 
    myDir = GetFolder() 
    fn = Dir(myDir & "*.gpc") 
    Do While fn  "" 
        ff = FreeFile 
        Open myDir & "" & fn For Input As #ff 
        Do While Not EOF(ff) 
            Line Input #ff, txt 
            x =  Split(txt, ",") 
            n = n + 1 
            Redim Preserve a(1 To n) 
            a(n) = x 
        Loop 
        Close #ff 
        With ThisWorkbook. Sheets(1) 
            . Cells(t + 2, 3).Value = fn 
            For i = 1 To n 
                .Cells(i + t + 1, 4).Resize(, UBound(a(i)) + 1).Value = a(i) 
            Next 
        End With 
        Erase a: t = t + n + 0: n = 0 
        fn = Dir() 
    Loop 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


I cant seen to get the cancel button to work properly. i know how to make it work by the If XXX = False... method, but since i need to use with i can figure out how to make it work properly. What Do i need to change? Where do i add the If vbCancel = False, or something else?

Heres my code


	VB:
	
 ChooseLocation_Click() 
    Dim MyFolder As String 
    With Application.FileDialog(msoFileDialogFolderPicker) 
        .Show 
        MyFolder = .SelectedItems(1) 
    End With 
    Location = MyFolder & "" 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


LS,

from Excel with VBA using a UserForm I can display the files in a special directory, using:

With Application.FileDialog(msoFileDialogOpen)
.InitialFileName = strPath & "*"
.AllowMultiSelect = False
.Show
End With

How do I manage that from that FileDiaolog a file (.xls, .doc or .txt) can be opened?

Doubleclick on the file gives no result.

Hello and good morning, I am trying to use a filedialog object to get a path
from a custom DLL. The code in the DLL is the following:

--- Code Snippet ---
Function GetNumb() As String
Set FP = Application.FileDialog(msoFileDialogFolderPicker)
With FP
.Title = "Folder Picker"
End With
If FP.Show <> 0 Then
GetNumb = StrConv(FP.SelectedItems.Item(1) & "", vbFromUnicode)
Else
MsgBox "user hit Cancel"
End If
End Function

---Code Snippet ---

My question/behavour is this. When I choose the Save/Cancel Buttons. The
code starts a new Excel object (I think it is an object because in my taskbar
I have another Excel window. If I try and maximize it it just is a blank
workbook. The Excel works code works but this blank workbook is there. Here
is how I am calling the function. It seems that the code executing when
selecting the Open/Cancel buttons does not have the focus.
One of the things I was going to try was to minmize Excel afer executing the
code when the Open/Cancel button. but the problem with the additional
workbook still has me baffled.
Any suggestions please let me know.
BTW: This code works perfectly outside the DLL.
Thanks for any input.

--- Code Snippet ---
Private Declare Function GetNumb Lib "g:paulstringsPart2string2dll.dll"
() As String

Private Sub CHKNet()
Dim Default_DIR As String
Default_DIR = GetNumb
MsgBox Default_DIR
End Sub

Hello,

I am currently using VBA code to import multiple .txt and .tab files into excel. Each file has a header row and data. When the macro imports these files, I want it to only use one header row instead of what it is doing now. Is this even possible with variable file names? Here is a copy of the code I am using:

Sub Import_Text()

Dim myFolder, TabFile, fso As Object, fPath As String

  ' Turn off some Excel functions that are not needed
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
  ' Import files
    Set fso = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count > 0 Then fPath = .SelectedItems(1) & "" Else Exit Sub
    End With
    Set myFolder = fso.GetFolder(fPath).Files
      ' Open each file sequentially
        For Each TabFile In myFolder
            If LCase(TabFile) Like "*.txt" Then
              ' Import data from Text file
                With Workbooks.Open(Filename:=TabFile, Delimiter:=1)
                    With ThisWorkbook.ActiveSheet
                        ActiveSheet.UsedRange.Copy _
                        Destination:=.Cells(.Rows.Count, "A").End(xlUp)(2)
                    End With
                 .Close SaveChanges:=False
                End With
            End If
        Next TabFile
  ' clean up
    TabFile = vbNullString
  ' Turn Excel functions back on
    With Application
      .Calculation = xlCalculationAutomatic
      .DisplayStatusBar = True
      .EnableEvents = True
    End With
End Sub
Please find attached example workbook and source files. Any assistance in this matter is greatly appreciated....Regards... Delta

How to use this code in excel 2000?

See..
Dim fd As FileDialog
Dim arquivo As String
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
If fd.Show = -1 Then
arquivo = fd.SelectedItems(1)
MsgBox "A pasta selecionada é " & arquivo
Else: arquivo = ""
End
End If
Cross-Post
http://www.ozgrid.com/forum/showthread.php?t=163073

Hi All,

I am using below code for my macro to save files at user selected location
The are some folders which I created during execution.I was unable to dele those folders or rename when macro excel sheet is opened

Getting an error lik this cannot delte used by other program or other person
See the pic
Please find code here

With Application.FileDialog(msoFileDialogFolderPicker)
      .InitialFileName = "C:Program Files"
      .Title = "Browse Folders"
      Action = .Show
      If Action = -1 Then
         Filelocation = .SelectedItems(1)
      Else
         Filelocation = ""
      End If
    End With
All please have alook

Hello,

I am using the below code to combine workbooks into a single sheet. The macro works perfectly for combinging the sheets, however, I can only run the code once. If I run the macro a second time, the data from the first run is overwritten. I would like it to be such that you can run the macro over and over again, and each set of new data will be appended to the next empty row. Unfortunately, I just haven't been able to get this to work. Any help is appreciated. Thanks!

A Sample of the destination workbook ("Invoice Workbook") and the source data ("TSR Template1-Test1") are in the attached zip.

Sub Consolidate()
' This macro imports (combines) all TSR workbooks into one sheet.

' This defines various objects
    Dim fName As String, fPath As String, fPathDone As String, OldDir As String
    Dim wbkOld As Workbook, wbkNew As Workbook, ws As Worksheet
    Dim LR As Long, NR As Long

' This speeds up the macro.
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
            
' This defines that the current workbook is the detination for all the TSR workbooks to be copied too.
    Set wbkNew = ThisWorkbook
    wbkNew.Activate
    Sheets("Invoice Data").Activate
    ActiveSheet.Unprotect
        
' This defines the range of each TSR workbook to be copied.
    NR = Range("A8:BP27").End(xlUp).Row + 1

' This sets the path of the folder where the TSR workbooks to be imported are stored.
    OldDir = CurDir
    With Application.FileDialog(msoFileDialogFolderPicker)
' The default path is the F drive
        .InitialFileName = ("F:")
        .Show
        If .SelectedItems.Count > 0 Then
            fPath = .SelectedItems(1)
        Else
            Exit Sub
        End If
    End With
    ChDir fPath
    fName = Dir("*.xl*")

' This imports the first sheet from each TSR workbook in the folder.
    Do While Len(fName) > 0
    Set wbkOld = Workbooks.Open(fName)
    Sheets(1).Activate
' This imports only rows where column BO is not blank.
    LR = Range("BO" & Rows.Count).End(xlUp).Row
' This copies only the given range of data from each TSR.
    Range("A8:BP27").Copy
' This pastes values in column A of the destination workbook.
    wbkNew.Sheets("Invoice Data").Range("A" & NR).PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                
' This closes the TSR workbooks and moves on to the next TSR workbook and the next empty row in the destination workbook.
    wbkOld.Close False
    NR = Range("A" & Rows.Count).End(xlUp).Row + 1
    fName = Dir
    Loop

' This clears data in entire rows where Column A (AFG#) is blank.
    Dim myColm As Range
    Set myColm = Columns("A:A")
    On Error Resume Next
    myColm.SpecialCells(xlCellTypeBlanks).EntireRow.ClearContents
    Range("A1").Select
    
' This restores the original working path.
    ChDir OldDir
    
' This reprotects the sheet.
    Sheets("Invoice Data").Activate
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
        , AllowFormattingCells:=True, AllowFormattingColumns:=True, _
        AllowFormattingRows:=True, AllowFiltering:=True, AllowUsingPivotTables:= _
        True
    
' This resets the settings we changed to speed up the macro.
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.Calculation = xlAutomatic


    
End Sub


Hi,

I have been using the following code to move files into the a relevant folder based on the first part of the file's name:


	VB:
	
 test() 
    Dim myDir As String 
    n = 0 
    With Application.FileDialog(msoFileDialogFolderPicker) 
        If .Show = True Then 
            myDir = .SelectedItems(1) 
        Else 
            Exit Sub 
        End If 
    End With 
    MoveFiles myDir, "*.xls*" 
    MsgBox "Action is complete" 
End Sub 
 
 
Private Sub MoveFiles(myDir, fn) 
    Dim fso As Object, myFolder As Object, myFile As Object, NewFolder 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    For Each myFile In fso.getfolder(myDir).Files 
        If myFile.Name Like fn Then 
            NewFolder = myDir & "" & Trim(Split(myFile.Name, "_")(0)) & "" 
            CreateFolder NewFolder 
            myFile.Move NewFolder 
        End If 
    Next 
End Sub 
 
 
Private Sub CreateFolder(NewFolder) 
    Dim fso As Object 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    If Not fso.folderexists(NewFolder) Then 
        fso.CreateFolder NewFolder 
    End If 
    Set fso = Nothing 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Is there anyway that the folder picker can default to a particular folder location on my shared drive? At the moment, it defaults to My Documents.

Any help would be greatly appreciated.

Many thanks.

Best regards,

rkapadia16

I have the user select an input and output folder using the below function. Works Great. However the dialog box only allows to view the folders, not files too. Is there a way while picking your folder to be able to have the files within the folder show up so that the user knows they are selecting the correct folder?


	VB:
	
 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
        .Title = fldSt 
        .AllowMultiSelect = False 
        .InitialFileName = strPath 
        If .Show  -1 Then Goto NextCode 
        sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Good Morning,

I'd like to use Application.OnKey to have specific keystrokes execute procedures while a UserForm is active. Any advice?

For instance, if the user hits 'f' while a userform is active, I want a simple procedure to increment a public counter to be executed. If the user hits 'd', I'd like a procedure to decrement a public counter to be executed.

I do realize that using the Accelerator in Command Buttons will allow me to do this but I'd rather allow my users to hit a single key rather than a key combination like 'alt-s'. I'd also like to allow 2 keys to execute the same procedure to allow for left handed users and right handed users.

Thanks for your help
Eric

I have the below code for the user to pick a folder that will be used as the input folder. I also need to browse to a folder to designate as an output folder. Can I do this at the same time some how. How can I write something so that a user can choose an input folder and an output folder? Thanks for the help.


	VB:
	
 
    Dim fldr As FileDialog 
    Dim sItem As String 
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker) 
    With fldr 
        .Title = "Select an Input Folder" 
        .AllowMultiSelect = False 
        .InitialFileName = strPath 
        If .Show  -1 Then Goto NextCode 
        sItem = .SelectedItems(1) 
    End With 
NextCode: 
    GetFolder = sItem 
    Set fldr = Nothing 
End Function 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hello!
This is my first post to the forum although I've read lots of posts from here!

Anyway, I've built a worksheet with a timer using "Application.OnTime" which works just fine... I start the timer by pressing a button on the worksheet. Now I want to be able to activate a macro upon hitting a key on the keyboard while the timer is still running. I've managed (successfully) to use "Application.OnKey" to activate my macro when hitting a specific key, however, not when the timer is running.

Is it possible to have the timer running and still be able to register an OnKey event?? Any help is appreciated! Thank you!
/Ida

Here are my relevant codes:

	VB:
	
 Workbook_Open() 
    Application.OnKey "{F4}", "keyPressMacro" 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

	VB:
	
 keyPressMacro() 
     'Do something...
    MsgBox("Hello!") 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

	VB:
	
 StartTimer() 
    RunWhen = Now + TimeSerial(0, 0, 1) 
    Application.OnTime EarliestTime:=RunWhen, Procedure:="updateTime", _ 
    schedule:=True 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines

	VB:
	
 updateTime() 
     'Do some stuff...
    Range("A1") = Now 
    StartTimer ' Reschedule the procedure
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines


Hello everyone,

I need to ask a question. As some of you know I use a certain routine for pulling information from a database (code below), my problem is it runs fine in Office 2K, when I run it in 97 it returns nothing, except for the recordset column fields, so I know it is making the connection to the database. I have tried changing the Activex Data Objects to see if that had anything to do with it, and it does not.

Any help you all can give is greatly appreciated.

Thank you,

Bruce

Function SigmaDB(Sheet As String, ByVal Src As String)
'Application.ScreenUpdating = False
Dim DBName As String 'DataBase Path as String
Dim Cnct As String 'ADO connection
Dim Conn As ADODB.Connection
Dim Recordset As ADODB.Recordset
Dim Col As Integer 'column variable for recordset field labels
Dim strSQL As String 'query string
Dim DataStorage As String 'worksheet range where database path is stored
Sheets(Sheet).Select 'select worksheet for data input
DataStorageDB = Sheets("DataStorage").Range("B1").Value 'worksheet range of database path
Dim i As Integer

On Error Resume Next

Dim DBPath As String
Dim Msg As String
'//Allow User to pick folder that contains database
If DataStorageDB "" Then
If (MsgBox("The Last DataBase Path Used Was " & DataStorageDB & vbCrLf _
& "Do You Want To Use This Database?", vbYesNo, "Database Last Used") = vbYes) Then
DBPath = DataStorageDB
GetFranNum
GoTo BusinessModel

End If

With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Application.DefaultFilePath & ""
.Title = "Please Select The Path Of Database You Wish To Use"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "No Path Selected"
Else
DBPath = .SelectedItems(1)
DataStorageDB = DBPath
GetFranNum
End If

End With
End If

BusinessModel:
Select Case Sheets(Sheet).Name

Case "HistoryByWeek"

DBName = DBPath & "mm.mdb"

strSQL = "SELECT DatePart('ww', Date_Saturday) AS WeekNumber, Date_Saturday, Format(Cust_Revenue, '$###0.00' As WeeklyRevenue " & _
"FROM HistoryWeek " & _
"WHERE FranNum = " & frmFranNum.lstFranNum.Selected(1) & _
"ORDER BY Date_Saturday"
Src = strSQL

End Select

Set Conn = New ADODB.Connection
Cnct = "Provider=Microsoft.Jet.OLEDB.4.0; "
Cnct = Cnct & "Data Source=" & DBName & ";"
Conn.Open ConnectionString:=Cnct

Set Recordset = New ADODB.Recordset

With Recordset

.Open Source:=Src, ActiveConnection:=Conn

For Col = 0 To Recordset.Fields.Count - 1
Range("A1").Offset(0, Col).Value = UCase( _
Recordset.Fields(Col).Name)
Next

Range("A" & Rows.Count).End(xlUp).Offset(1, 0).CopyFromRecordset Recordset

Set Recordset = Nothing
Conn.Close
Set Conn = Nothing

End With

'Application.ScreenUpdating = True
End Function

Hello,

I am in need of a Directory Selector/Picker. For previous applications I have used the FileDialog(msoFileDialogFolderPicker). However this allows users to create and delete directories etc. I would like to either disable these functions (and others) on the FileDialog(msoFileDialogFolderPicker) or have a simple directory picker.

I am sure there will be one on a site somewhere.......

on your marks .....get set........go!

TIA,

Alan.

The following code works great in Office 2003, but causes issues with 2010. It was installed on a personal macro folder in XLSTART.


	VB:
	
 ListFiles() 
     
    Dim fd As FileDialog 
    Dim PathOfSelectedFolder As String 
    Dim SelectedFolder 
    Dim SelectedFolderTemp 
    Dim MyPath As FileDialog 
    Dim ExtraSlash 
    ExtraSlash = "" 
    Dim MyFile 
    Dim Mystring As String 
    Dim sDate As String 
    Dim sApp As String 
     
    sDate = InputBox("Input the date you want to appear in the Filename") 
    sApp = InputBox("Type the name of the app you are using") 
    MsgBox ("Now browse and select the folder containing the files you want to rename") 
     
     'Prepare to open a modal window, where a folder is selected
    Set MyPath = Application.FileDialog(msoFileDialogFolderPicker) 
    With MyPath 
         'Open modal window
        .AllowMultiSelect = False 
        If .Show Then 
             
             'The user has selected a folder
             'Loop through the chosen folder
            For Each SelectedFolder In .SelectedItems 
                 
                 'Name of the selected folder
                PathOfSelectedFolder = SelectedFolder & ExtraSlash 
                Set fs = CreateObject("Scripting.FileSystemObject") 
                Set SelectedFolderTemp = fs.GetFolder(PathOfSelectedFolder) 
                 'Loop through the files in the selected folder
                For Each MyFile In SelectedFolderTemp.Files 
                     'Name of file
                    On Error Resume Next 
                    If InStr(1, MyFile.Name, "cfc_sec_adm__acct_acc_jrnl_" & sApp & "uat", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Acct Acct UAT.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__acct_acc_jrnl_" & sApp, vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Acct Acct PROD.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__app_user_jrnl_" & sApp & "uat", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " App User UAT.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__app_user_jrnl_" & sApp, vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " App User PROD.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__d_user_info_jrnl_" & sApp & "uat", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " D User UAT.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__d_user_info_jrnl_" & sApp, vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " D User PROD.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__priv_jrnl_" & sApp & "uat", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Priv UAT.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__priv_jrnl_" & sApp & "", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Priv PROD.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__priv_jrnl_summary_" & sApp & "uat", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Priv Summary UAT.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__priv_jrnl_summary_" & sApp & "", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Priv Summary PROD.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__user_ftu_jrnl_" & sApp & "uat", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Ftu UAT.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__user_ftu_jrnl_" & sApp & "", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Ftu PROD.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__user_ftu_jrnl_summary_" & sApp & "uat", vbTextCompare) > 0
Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Ftu Summary UAT.out" 
                        On Error Resume Next 
                    ElseIf InStr(1, MyFile.Name, "cfc_sec_adm__user_ftu_jrnl_summary_" & sApp & "", vbTextCompare) > 0 Then 
                        Name MyFile.Name As sDate & " CFC GFTS " & UCase(sApp) & " Ftu Summary PROD.out" 
                         
                         'Name MyFile.Name As sDate & " " & ".xls"
                         'DO STUFF TO THE FILE, for example:
                    End If 
                Next 
            Next 
        End If 
    End With 
    MsgBox ("Complete") 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
This is designed to rename files in a folder when they have certain criteria. It saves a TON of work, but I can't install it on machines that use 2010 for some reason. Any suggested workarounds?

I have a usereform that is called by a button. But i cant seem to pass the range defined by the button to the userform. I have tried everything i can think of. What is the correct technique to pass my range around? I cannot just define the range in the userform because multiple buttons will call the userform, and the range will be unique to all buttons

This is my button code

	VB:
	
 Button1_Click() 
    Load Publish 
    With Publish 
        Dim rngSheetInfo As Range 
        Set rngSheetInfo = ThisWorkbook.Worksheets("Summary").Range("B5") 
        .TicketNum.Caption = (rngSheetInfo.Value) 
    End With 
    Publish.Show 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
This is the code of the userform, the sub ok_click is where my range named rngSheetInfo is to be used


	VB:
	
 UserForm_Initialize() 
    OfficeCopy.Value = True 
    OriginalCopy.Value = True 
    CustomerCopy.Value = False 
    Printer.Value = True 
    pdf.Value = False 
End Sub 
Private Sub Cancel_Click() 
    End 
End Sub 
Private Sub ChooseLocation_Click() 
    Dim MyFolder As String 
    With Application.FileDialog(msoFileDialogFolderPicker) 
        .Show 
        MyFolder = .SelectedItems(1) 
        Location = MyFolder 
    End With 
End Sub 
 
Private Sub Ok_Click() 
     
    Dim ShYellow As Object 
    Dim ShPink As Object 
    If Me.Printer.Value = True Then 
        PrtOK = True 
        If Application.Dialogs(xlDialogPrinterSetup).Show = False Then 
            PrtOK = False 
            Exit Sub 
        End If 
        If Me.OriginalCopy.Value = True Then 
            ThisWorkbook.Worksheets(CStr(rngSheetInfo.Value)).PrintOut 
            rngSheetInfo.Offset(0, 1).Value = rngSheetInfo.Offset(0, 1).Value + 1 
        End If 
        If Me.OfficeCopy.Value = True Then 
            With ThisWorkbook.Worksheets(CStr(rngSheetInfo.Value)) 
                Set ShPink = .Shapes.AddTextEffect(PresetTextEffect:=14, Text:="Pink", FontName:="Arial Black", FontSize:=48,
FontBold:=False, FontItalic:=False, Left:=200, Top:=0) 
                .PrintOut 
                If Me.HoldPink.Value = False Then 
                    ShPink.Delete 
                End If 
                rngSheetInfo.Offset(0, 1).Value = rngSheetInfo.Offset(0, 1).Value + 1 
            End With 
        End If 
        If Me.CustomerCopy.Value = True Then 
            With ThisWorkbook.Worksheets(CStr(rngSheetInfo.Value)) 
                Set ShYellow = .Shapes.AddTextEffect(PresetTextEffect:=6, Text:="Customer Copy", FontName:="Arial Black",
FontSize:=32, FontBold:=False, FontItalic:=False, Left:=200, Top:=0) 
                .PrintOut 
                rngSheetInfo.Offset(0, 1).Value = rngSheetInfo.Offset(0, 1).Value + 1 
                ShYellow.Delete 
            End With 
        End If 
        PrtOK = False 
    End If 
     
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines



No luck finding an answer? You could always try Google.