[Okta Webinar] Learn how to a build a cloud-first strategyRegister Now

x
?
Solved

Add directory path to script

Posted on 2011-10-14
12
Medium Priority
?
265 Views
Last Modified: 2012-08-13
andrewssd3 provided the following wonderful script that is going to save huge amounts of time.

Currently the script is hard coded to one path,   Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search

I'd like the script to prompt for the starting path and work from that point. For example, If I select c:\database\time\123 as my starting point, that it would use that instead of the hard coded path.
 
The script source code is shown below:

As I explained to Andrew on my previous question, I am not very knowledgeable about scripting and macros.

This is the source code Andrew created for me.

Option Explicit

Private mwbkMaster As Excel.Workbook     ' this totals workbook
Private mrngEQOut As Excel.Range         ' next available cell for totals for EQ
Private mrngLabOut As Excel.Range        ' next available cell for totals for Labor
Private mobjFSO As Object           'object        'Scripting.FileSystemObject
   
Public Sub ImportAll()

   
    Dim shtEQTot As Excel.Worksheet
    Dim shtLabTot As Excel.Worksheet


    Dim fldMaster As Object        'Scripting.Folder
    Dim fldSub As Object        'Scripting.Folder
    Dim filData As Object        'Scripting.File
    Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search
   
    Set mwbkMaster = ThisWorkbook
    ' get the EQ totals sheet and find the first available row
    Set shtEQTot = mwbkMaster.Worksheets("EQ Totals")
    Set mrngEQOut = shtEQTot.UsedRange
    Set mrngEQOut = mrngEQOut.Offset(mrngEQOut.Rows.Count, 1).Resize(1, 1)
   
    ' get the Labor totals sheet and find the first available row
    Set shtLabTot = mwbkMaster.Worksheets("Labor Totals")
    Set mrngLabOut = shtLabTot.UsedRange
    Set mrngLabOut = mrngLabOut.Offset(mrngLabOut.Rows.Count, 1).Resize(1, 1)
   
    ' create the file system object
    Set mobjFSO = CreateObject("Scripting.FileSystemObject")
    ' find the master folder
    Set fldMaster = mobjFSO.GetFolder(cstrDataLoc)
   
    ' loop through all the sub folders
    For Each fldSub In fldMaster.SubFolders
        ' loop through all the files (should be only one?)
        For Each filData In fldSub.Files
            ' check it's some sort of Excel file and process it
            If LCase$(mobjFSO.GetExtensionName(filData.Name)) Like "xls*" Then
                Call ProcessFile(filData.Path)
            End If
        Next filData
    Next fldSub
   
    Set mrngEQOut = Nothing
    Set mrngLabOut = Nothing
    Set mobjFSO = Nothing
   
    MsgBox "Completed"
   
End Sub

Private Sub ProcessFile(ByVal strPath As String)
    ' called once for each workbook found
    Dim wbkIndiv As Excel.Workbook
    Dim wksCurrIn As Excel.Worksheet
    Dim rngIn As Excel.Range
   
    Dim strCaption As String            ' the name of the current input workbook
    Dim aData As Variant
   
    strCaption = mobjFSO.GetBaseName(strPath)
   
    ' open the data workbook
    Set wbkIndiv = Application.Workbooks.Open(Filename:=strPath, _
            UpdateLinks:=False, ReadOnly:=True, addtomru:=False)
   
    ' get the first sheet
    Set wksCurrIn = wbkIndiv.Worksheets("EQ Totals")
    ' get all data for this sheet into an array
    Set rngIn = wksCurrIn.UsedRange
    aData = rngIn.Value
    ' prepare the output range by making it the right size to receive the data
    Set mrngEQOut = mrngEQOut.Resize(rngIn.Rows.Count, rngIn.Columns.Count)
    ' put in the values from the input sheet
    mrngEQOut.Value = aData
    ' put in the label identifying this row
    mrngEQOut.Offset(0, -1).Resize(mrngEQOut.Rows.Count, 1).Value = strCaption
   
   
    ' get the next sheet (NB this is the same as the previous sheet - left separate
    ' in case something needs to change at a later point for one sheet
    Set wksCurrIn = wbkIndiv.Worksheets("Labor Totals")
    ' get all data for this sheet into an array
    Set rngIn = wksCurrIn.UsedRange
    aData = rngIn.Value
    ' prepare the output range by making it the right size to receive the data
    Set mrngLabOut = mrngLabOut.Resize(rngIn.Rows.Count, rngIn.Columns.Count)
    ' put in the values from the input sheet
    mrngLabOut.Value = aData
    ' put in the label identifying this row
    mrngLabOut.Offset(0, -1).Resize(mrngLabOut.Rows.Count, 1).Value = strCaption
   
    'move the output ranges on
    Set mrngEQOut = mrngEQOut.Offset(mrngEQOut.Rows.Count, 0)
    Set mrngLabOut = mrngLabOut.Offset(mrngLabOut.Rows.Count, 0)
    wbkIndiv.Saved = True
    ' close the data workbook
    Application.DisplayAlerts = False
    wbkIndiv.Close xlDoNotSaveChanges
    Application.DisplayAlerts = True
   
   
End Sub

0
Comment
Question by:RedstoneIT
  • 5
  • 4
  • 2
  • +1
12 Comments
 
LVL 14

Expert Comment

by:Tommy Kinard
ID: 36968676
change
Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search
to

Dim cstrDataLoc As String
cstrDataLoc= InputBox ("Please Enter the starting Point of your Process")

HTH
0
 
LVL 17

Expert Comment

by:wobbled
ID: 36968686
you could get rid of this line

Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search

And in the code put something like

strDataLoc = Input("please enter the path of the directory")

replace this line
  Set fldMaster = mobjFSO.GetFolder(cstrDataLoc)
with
  Set fldMaster = mobjFSO.GetFolder(strDataLoc)
0
 
LVL 17

Expert Comment

by:wobbled
ID: 36968698
whoops  missed out a bit

you could get rid of this line

Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search

And in the code put something like

Dim strDataLoc as string

strDataLoc = InputBox("please enter the path of the directory")

replace this line
  Set fldMaster = mobjFSO.GetFolder(cstrDataLoc)
with
  Set fldMaster = mobjFSO.GetFolder(strDataLoc)
0
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 

Author Comment

by:RedstoneIT
ID: 36968713
ok, the solutions provided would work, but this will be used by users who will not know how to find the path except by browsing. Is there a way to allow them to select the directory from a browser such as a common dialog box or something?
0
 

Author Comment

by:RedstoneIT
ID: 36968797
I just tried the solutions and it is not importing the information from the folder location like it does if the location is static
0
 
LVL 17

Accepted Solution

by:
wobbled earned 1600 total points
ID: 36968873
Here you go - added a function to allow you select the folder
Option Explicit

Private mwbkMaster As Excel.Workbook     ' this totals workbook
Private mrngEQOut As Excel.Range         ' next available cell for totals for EQ
Private mrngLabOut As Excel.Range        ' next available cell for totals for Labor
Private mobjFSO As Object           'object        'Scripting.FileSystemObject
   
Public Sub ImportAll()

   
    Dim shtEQTot As Excel.Worksheet
    Dim shtLabTot As Excel.Worksheet


    Dim fldMaster As Object        'Scripting.Folder
    Dim fldSub As Object        'Scripting.Folder
    Dim filData As Object        'Scripting.File
    'Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search
    
    Dim strFolder As String
    
    strFolder = GetFolder("")
   
    Set mwbkMaster = ThisWorkbook
    ' get the EQ totals sheet and find the first available row
    Set shtEQTot = mwbkMaster.Worksheets("EQ Totals")
    Set mrngEQOut = shtEQTot.UsedRange
    Set mrngEQOut = mrngEQOut.Offset(mrngEQOut.Rows.Count, 1).Resize(1, 1)
   
    ' get the Labor totals sheet and find the first available row
    Set shtLabTot = mwbkMaster.Worksheets("Labor Totals")
    Set mrngLabOut = shtLabTot.UsedRange
    Set mrngLabOut = mrngLabOut.Offset(mrngLabOut.Rows.Count, 1).Resize(1, 1)
   
    ' create the file system object
    Set mobjFSO = CreateObject("Scripting.FileSystemObject")
    ' find the master folder
    Set fldMaster = mobjFSO.GetFolder(strFolder)
   
    ' loop through all the sub folders
    For Each fldSub In fldMaster.SubFolders
        ' loop through all the files (should be only one?)
        For Each filData In fldSub.Files
            ' check it's some sort of Excel file and process it
            If LCase$(mobjFSO.GetExtensionName(filData.Name)) Like "xls*" Then
                Call ProcessFile(filData.Path)
            End If
        Next filData
    Next fldSub
   
    Set mrngEQOut = Nothing
    Set mrngLabOut = Nothing
    Set mobjFSO = Nothing
   
    MsgBox "Completed"
   
End Sub

Private Sub ProcessFile(ByVal strPath As String)
    ' called once for each workbook found
    Dim wbkIndiv As Excel.Workbook
    Dim wksCurrIn As Excel.Worksheet
    Dim rngIn As Excel.Range
   
    Dim strCaption As String            ' the name of the current input workbook
    Dim aData As Variant
   
    strCaption = mobjFSO.GetBaseName(strPath)
   
    ' open the data workbook
    Set wbkIndiv = Application.Workbooks.Open(Filename:=strPath, _
            UpdateLinks:=False, ReadOnly:=True, addtomru:=False)
   
    ' get the first sheet
    Set wksCurrIn = wbkIndiv.Worksheets("EQ Totals")
    ' get all data for this sheet into an array
    Set rngIn = wksCurrIn.UsedRange
    aData = rngIn.Value
    ' prepare the output range by making it the right size to receive the data
    Set mrngEQOut = mrngEQOut.Resize(rngIn.Rows.Count, rngIn.Columns.Count)
    ' put in the values from the input sheet
    mrngEQOut.Value = aData
    ' put in the label identifying this row
    mrngEQOut.Offset(0, -1).Resize(mrngEQOut.Rows.Count, 1).Value = strCaption
   
   
    ' get the next sheet (NB this is the same as the previous sheet - left separate
    ' in case something needs to change at a later point for one sheet
    Set wksCurrIn = wbkIndiv.Worksheets("Labor Totals")
    ' get all data for this sheet into an array
    Set rngIn = wksCurrIn.UsedRange
    aData = rngIn.Value
    ' prepare the output range by making it the right size to receive the data
    Set mrngLabOut = mrngLabOut.Resize(rngIn.Rows.Count, rngIn.Columns.Count)
    ' put in the values from the input sheet
    mrngLabOut.Value = aData
    ' put in the label identifying this row
    mrngLabOut.Offset(0, -1).Resize(mrngLabOut.Rows.Count, 1).Value = strCaption
   
    'move the output ranges on
    Set mrngEQOut = mrngEQOut.Offset(mrngEQOut.Rows.Count, 0)
    Set mrngLabOut = mrngLabOut.Offset(mrngLabOut.Rows.Count, 0)
    wbkIndiv.Saved = True
    ' close the data workbook
    Application.DisplayAlerts = False
    wbkIndiv.Close xlDoNotSaveChanges
    Application.DisplayAlerts = True
   
   
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

Open in new window

0
 
LVL 59

Assisted Solution

by:Chris Bottomley
Chris Bottomley earned 400 total points
ID: 36969083
Added a call to getPath to return the path as in interactive activity.

Chris
Option Explicit

Private mwbkMaster As Excel.Workbook     ' this totals workbook
Private mrngEQOut As Excel.Range         ' next available cell for totals for EQ
Private mrngLabOut As Excel.Range        ' next available cell for totals for Labor
Private mobjFSO As Object           'object        'Scripting.FileSystemObject
   
Public Sub ImportAll()

   
    Dim shtEQTot As Excel.Worksheet
    Dim shtLabTot As Excel.Worksheet


    Dim fldMaster As Object        'Scripting.Folder
    Dim fldSub As Object        'Scripting.Folder
    Dim filData As Object        'Scripting.File
    'Const cstrDataLoc As String = "G:\Database work for Chad\Time" ' starting location of search
    
    Dim strFolder As String
    
    strFolder = getPath
   
    Set mwbkMaster = ThisWorkbook
    ' get the EQ totals sheet and find the first available row
    Set shtEQTot = mwbkMaster.Worksheets("EQ Totals")
    Set mrngEQOut = shtEQTot.UsedRange
    Set mrngEQOut = mrngEQOut.Offset(mrngEQOut.Rows.Count, 1).Resize(1, 1)
   
    ' get the Labor totals sheet and find the first available row
    Set shtLabTot = mwbkMaster.Worksheets("Labor Totals")
    Set mrngLabOut = shtLabTot.UsedRange
    Set mrngLabOut = mrngLabOut.Offset(mrngLabOut.Rows.Count, 1).Resize(1, 1)
   
    ' create the file system object
    Set mobjFSO = CreateObject("Scripting.FileSystemObject")
    ' find the master folder
    Set fldMaster = mobjFSO.GetFolder(strFolder)
   
    ' loop through all the sub folders
    For Each fldSub In fldMaster.SubFolders
        ' loop through all the files (should be only one?)
        For Each filData In fldSub.Files
            ' check it's some sort of Excel file and process it
            If LCase$(mobjFSO.GetExtensionName(filData.Name)) Like "xls*" Then
                Call ProcessFile(filData.Path)
            End If
        Next filData
    Next fldSub
   
    Set mrngEQOut = Nothing
    Set mrngLabOut = Nothing
    Set mobjFSO = Nothing
   
    MsgBox "Completed"
   
End Sub

Private Sub ProcessFile(ByVal strPath As String)
    ' called once for each workbook found
    Dim wbkIndiv As Excel.Workbook
    Dim wksCurrIn As Excel.Worksheet
    Dim rngIn As Excel.Range
   
    Dim strCaption As String            ' the name of the current input workbook
    Dim aData As Variant
   
    strCaption = mobjFSO.GetBaseName(strPath)
   
    ' open the data workbook
    Set wbkIndiv = Application.Workbooks.Open(Filename:=strPath, _
            UpdateLinks:=False, ReadOnly:=True, addtomru:=False)
   
    ' get the first sheet
    Set wksCurrIn = wbkIndiv.Worksheets("EQ Totals")
    ' get all data for this sheet into an array
    Set rngIn = wksCurrIn.UsedRange
    aData = rngIn.Value
    ' prepare the output range by making it the right size to receive the data
    Set mrngEQOut = mrngEQOut.Resize(rngIn.Rows.Count, rngIn.Columns.Count)
    ' put in the values from the input sheet
    mrngEQOut.Value = aData
    ' put in the label identifying this row
    mrngEQOut.Offset(0, -1).Resize(mrngEQOut.Rows.Count, 1).Value = strCaption
   
   
    ' get the next sheet (NB this is the same as the previous sheet - left separate
    ' in case something needs to change at a later point for one sheet
    Set wksCurrIn = wbkIndiv.Worksheets("Labor Totals")
    ' get all data for this sheet into an array
    Set rngIn = wksCurrIn.UsedRange
    aData = rngIn.Value
    ' prepare the output range by making it the right size to receive the data
    Set mrngLabOut = mrngLabOut.Resize(rngIn.Rows.Count, rngIn.Columns.Count)
    ' put in the values from the input sheet
    mrngLabOut.Value = aData
    ' put in the label identifying this row
    mrngLabOut.Offset(0, -1).Resize(mrngLabOut.Rows.Count, 1).Value = strCaption
   
    'move the output ranges on
    Set mrngEQOut = mrngEQOut.Offset(mrngEQOut.Rows.Count, 0)
    Set mrngLabOut = mrngLabOut.Offset(mrngLabOut.Rows.Count, 0)
    wbkIndiv.Saved = True
    ' close the data workbook
    Application.DisplayAlerts = False
    wbkIndiv.Close xlDoNotSaveChanges
    Application.DisplayAlerts = True
   
   
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 getPath()
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0
Const OPTIONS = 0

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(MY_COMPUTER)
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path

Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder _
    (WINDOW_HANDLE, "Select a folder:", OPTIONS, strPath)
      
If objFolder Is Nothing Then
    Wscript.Quit
End If

Set objFolderItem = objFolder.Self
getPath = objFolderItem.Path

End Function

Open in new window

0
 

Author Comment

by:RedstoneIT
ID: 36969424
Chris,

I'[m getting a variable not defined error on function getpath
0
 

Author Comment

by:RedstoneIT
ID: 36969449
Wobbled, your code is working when I chose the original hard coded path, but when I select other paths it doesnt import the xls files.

0
 

Author Comment

by:RedstoneIT
ID: 36969484
Ok Wobbled I figured out the problem. Its looking for sub folders under the main folder. without them it doesn't see the excel files in the folder.

I'll open up that problem as a new question.

Thank you all for responding.

0
 
LVL 17

Expert Comment

by:wobbled
ID: 36969517
glad to have helped :)
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 36969684
I actually took the comment script too literally and assumed it was for a VB Script!  A look at the block I cut and pasted would have corrected me ... but I didn't do it.

Chris
0

Featured Post

Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

This article describes how you can use Custom Document Properties to store settings and other information in your workbook so that they will be available the next time you open the workbook.
This article describes how to use a set of graphical playing cards to create a Draw Poker game in Excel or VB6.
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.
This Micro Tutorial will demonstrate in Microsoft Excel how to add style and sexy appeal to horizontal bar charts.

872 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question