Solved

Change from folder location in a cell to opening a prompt to select folder

Posted on 2013-05-23
5
249 Views
Last Modified: 2013-05-23
Good morning,

How can I change this macro to pull all data in a Directory by opening a prompt and selecting the folder instead of the current process of copying the folder address into a cell?
Thank you!
ParseText-EE.xls
0
Comment
Question by:crepe
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 3
  • 2
5 Comments
 
LVL 28

Expert Comment

by:omgang
ID: 39191607
Give this a shot
OM Gang



Sub DoIt()
    Dim fld As FileDialog
    Dim sFolderLoc As String
    Dim iCurrentRow As Long
    Dim i As Long
    Dim sTxtFilename As String

    Dim j As Long
    Dim sLine As String
    Dim sComputedResults
    Dim sComputedMaximum
    Dim sComputedMinimum

    With ThisWorkbook.ActiveSheet
        .Range("A1") = "File Name"
        .Range("B1") = "Computed Results"
        .Range("C1") = "Blank"
        .Range("D1") = "Computed Maximum"
        .Range("E1") = "Computed Minimum"
    End With

    iCurrentRow = 1
   
    'sFolderLoc = ThisWorkbook.ActiveSheet.Cells(2, 9).Value
    Set fld = Application.FileDialog(msoFileDialogFolderPicker)
    With fld
        .Title = "Pick your folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then GoTo Exit_DoIt
        sFolderLoc = fld.SelectedItems(1)
    End With
   
    sTxtFilename = ThisWorkbook.ActiveSheet.Cells(2, 10).Value
    sComputedResults = "Computed Results: "
    sComputedMaximum = "Computed Maximum: "
    sComputedMinimum = "Computed Minimum: "

    ' this assumes all files of type data are your data
    sTxtFilename = Dir(sFolderLoc & sTxtFilename)

    Do While sTxtFilename <> ""

        iCurrentRow = iCurrentRow + 1

        Open sFolderLoc & sTxtFilename For Input As #1

        ' no error checking here, assumes all txt files are ok
        Do While Not EOF(1)

            Input #1, sLine

            If Left(sLine, Len(sComputedResults)) = sComputedResults Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedResults))

                ThisWorkbook.ActiveSheet.Range("B" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMaximum)) = sComputedMaximum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMaximum))

                ThisWorkbook.ActiveSheet.Range("D" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMinimum)) = sComputedMinimum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMinimum))
                ThisWorkbook.ActiveSheet.Range("E" & iCurrentRow) = sLine
            End If
        Loop
        ThisWorkbook.ActiveSheet.Range("A" & iCurrentRow) = sTxtFilename
        Close #1
        'find next txt file
        sTxtFilename = Dir
    Loop
   
Exit_DoIt:
    Set fld = Nothing
   
End Sub
0
 

Author Comment

by:crepe
ID: 39191673
It doesn't seem to work. I want to pull all *.txt files in a folder. And I want to remove the cell references that is referenced here:
    sTxtFilename = ThisWorkbook.ActiveSheet.Cells(2, 10).Value
    sComputedResults = "Computed Results: "
    sComputedMaximum = "Computed Maximum: "
    sComputedMinimum = "Computed Minimum: "

    ' this assumes all files of type data are your data
    sTxtFilename = Dir(sFolderLoc & sTxtFilename)

Open in new window


I want it similar to this one:

Option Explicit

Sub Master()
    
    Dim StartPath As String
    Dim Results() As Variant
    
    StartPath = GetDirectory2
    
    If StartPath <> "" Then
        Application.ScreenUpdating = False
        ReDim Results(0) As Variant
        DoTheWork Results, StartPath
        Workbooks.Add
        Range("a1:b" & UBound(Results, 2)).Value = Application.Transpose(Results)
        Columns.AutoFit
        Application.ScreenUpdating = True
        MsgBox "Done"
    End If
    
End Sub

Private Sub DoTheWork(ByRef Results As Variant, FldPath As String)
    
    Dim fso As Object, fld As Object, fil As Object, sf As Object
    Dim WbWasOpen As Boolean
    Dim wb As Workbook, ws As Worksheet
    Dim GetValue As Variant
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set fld = fso.GetFolder(FldPath)
    
    On Error Resume Next

    For Each fil In fld.Files
        If LCase(fil.Name) Like "*verification*.xls*" Then
            Set wb = Workbooks(fil.Name)
            If Err <> 0 Then
                WbWasOpen = False
                Set wb = Workbooks.Open(fil.Path)
                Err.Clear
            Else
                WbWasOpen = True
            End If
            Set ws = wb.Worksheets("Finances")
            If Err = 0 Then
                GetValue = ws.Range("f12").Value
                If Not WbWasOpen Then wb.Close False
                If LBound(Results, 1) > 0 Then
                    ReDim Preserve Results(1 To 2, 1 To UBound(Results, 2) + 1) As Variant
                Else
                    ReDim Results(1 To 2, 1 To 2) As Variant
                    Results(1, 1) = "File"
                    Results(2, 1) = "Value"
                End If
                Results(1, UBound(Results, 2)) = fil.Path
                Results(2, UBound(Results, 2)) = GetValue
            Else
                Err.Clear
            End If
        End If
    Next
    
    On Error GoTo 0

    For Each sf In fld.SubFolders
        DoTheWork Results, sf.Path
    Next
    
End Sub

Private Function GetDirectory2(Optional Msg As String = "Select Folder:") As String
    
    ' Use this version when you want to be able to create a new directory and
    ' have the function return that path
    
    Dim objShell As Object 'Shell32.Shell
    Dim objFolder As Object 'Shell32.Folder
    Dim objFolderItem As Object 'Shell32.FolderItem
    
    GetDirectory2 = ""
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, Msg, 0, 0)
    
    If (Not objFolder Is Nothing) Then
        Set objFolderItem = objFolder.Self
        If (Not objFolderItem Is Nothing) Then
            GetDirectory2 = objFolderItem.Path
        End If
    End If
    
    Set objFolderItem = Nothing
    Set objFolder = Nothing
    Set objShell = Nothing
    
End Function

Open in new window

0
 
LVL 28

Expert Comment

by:omgang
ID: 39191748
First, the dialog is a Folder picker (not a file picker) so we can't specify a filter for file types, e.g. .txt or .data files.

Second, we simply need to add the trailing back slash to the folder path returned by the folder picker to get the code to work correctly.

How do you want this to work?  Do you want the user to use the picker to select a file from the target directory and then have the routine search the entire folder for all files matching the file type selected by the user?
OM Gang



Sub DoIt()
    Dim fld As FileDialog
    Dim sFolderLoc As String
    Dim iCurrentRow As Long
    Dim i As Long
    Dim sTxtFilename As String

    Dim j As Long
    Dim sLine As String
    Dim sComputedResults
    Dim sComputedMaximum
    Dim sComputedMinimum

    With ThisWorkbook.ActiveSheet
        .Range("A1") = "File Name"
        .Range("B1") = "Computed Results"
        .Range("C1") = "Blank"
        .Range("D1") = "Computed Maximum"
        .Range("E1") = "Computed Minimum"
    End With

    iCurrentRow = 1
   
    'sFolderLoc = ThisWorkbook.ActiveSheet.Cells(2, 9).Value
    Set fld = Application.FileDialog(msoFileDialogFolderPicker)
    With fld
        .Title = "Pick your folder"
        .AllowMultiSelect = False
        '.Filters.Clear
        '.Filters.Add "Text Files", "*.txt"
        If .Show <> -1 Then GoTo Exit_DoIt
        sFolderLoc = fld.SelectedItems(1)
    End With
   
    sTxtFilename = ThisWorkbook.ActiveSheet.Cells(2, 10).Value
    sComputedResults = "Computed Results: "
    sComputedMaximum = "Computed Maximum: "
    sComputedMinimum = "Computed Minimum: "

    ' this assumes all files of type data are your data
    sTxtFilename = Dir(sFolderLoc & "\" & sTxtFilename)

    Do While sTxtFilename <> ""

        iCurrentRow = iCurrentRow + 1

        Open sFolderLoc & "\" & sTxtFilename For Input As #1

        ' no error checking here, assumes all txt files are ok
        Do While Not EOF(1)

            Input #1, sLine

            If Left(sLine, Len(sComputedResults)) = sComputedResults Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedResults))

                ThisWorkbook.ActiveSheet.Range("B" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMaximum)) = sComputedMaximum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMaximum))

                ThisWorkbook.ActiveSheet.Range("D" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMinimum)) = sComputedMinimum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMinimum))
                ThisWorkbook.ActiveSheet.Range("E" & iCurrentRow) = sLine
            End If
        Loop
        ThisWorkbook.ActiveSheet.Range("A" & iCurrentRow) = sTxtFilename
        Close #1
        'find next txt file
        sTxtFilename = Dir
    Loop
   
Exit_DoIt:
    Set fld = Nothing
   
End Sub
0
 
LVL 28

Accepted Solution

by:
omgang earned 500 total points
ID: 39191865
Try this

OM Gang



Sub DoIt()
    Dim fld As FileDialog
    Dim sFolderLoc As String
    Dim iCurrentRow As Long
    Dim i As Long
    Dim sTxtFilename As String

    Dim j As Long
    Dim sLine As String
    Dim sComputedResults
    Dim sComputedMaximum
    Dim sComputedMinimum

    With ThisWorkbook.ActiveSheet
        .Range("A1") = "File Name"
        .Range("B1") = "Computed Results"
        .Range("C1") = "Blank"
        .Range("D1") = "Computed Maximum"
        .Range("E1") = "Computed Minimum"
    End With

    iCurrentRow = 1
   
    'sFolderLoc = ThisWorkbook.ActiveSheet.Cells(2, 9).Value
    'Set fld = Application.FileDialog(msoFileDialogFolderPicker)
        'open file picker instead of a folder picker
    Set fld = Application.FileDialog(msoFileDialogFilePicker)
   
        'set file picker dialog preferences
    With fld
        .Title = "Pick your file type"
        .AllowMultiSelect = False
            'you may want to comment out the next two lines if you want to allow users to select a variety of file types
        .Filters.Clear
        .Filters.Add "Text Files", "*.data"
        If .Show <> -1 Then GoTo Exit_DoIt
        sFolderLoc = fld.SelectedItems(1)
    End With
   
    'sTxtFilename = ThisWorkbook.ActiveSheet.Cells(2, 10).Value
        'set file type based upon what the user has selected
    sTxtFilename = "*." & Right(sFolderLoc, Len(sFolderLoc) - InStrRev(sFolderLoc, "."))
    sComputedResults = "Computed Results: "
    sComputedMaximum = "Computed Maximum: "
    sComputedMinimum = "Computed Minimum: "

        'set folder based upon location of file user has selected
    sFolderLoc = Left(sFolderLoc, InStrRev(sFolderLoc, "\"))

    ' this assumes all files of type data are your data
    sTxtFilename = Dir(sFolderLoc & "\" & sTxtFilename)

    Do While sTxtFilename <> ""

        iCurrentRow = iCurrentRow + 1

        Open sFolderLoc & "\" & sTxtFilename For Input As #1

        ' no error checking here, assumes all txt files are ok
        Do While Not EOF(1)

            Input #1, sLine

            If Left(sLine, Len(sComputedResults)) = sComputedResults Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedResults))

                ThisWorkbook.ActiveSheet.Range("B" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMaximum)) = sComputedMaximum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMaximum))

                ThisWorkbook.ActiveSheet.Range("D" & iCurrentRow) = sLine
            ElseIf Left(sLine, Len(sComputedMinimum)) = sComputedMinimum Then
                sLine = Right(sLine, Len(sLine) - Len(sComputedMinimum))
                ThisWorkbook.ActiveSheet.Range("E" & iCurrentRow) = sLine
            End If
        Loop
        ThisWorkbook.ActiveSheet.Range("A" & iCurrentRow) = sTxtFilename
        Close #1
        'find next txt file
        sTxtFilename = Dir
    Loop
   
Exit_DoIt:
    Set fld = Nothing
   
End Sub
0
 

Author Closing Comment

by:crepe
ID: 39192494
It's exactly what I wanted. Thank you!
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

Do you use a spreadsheet like Microsoft's Excel?  Have you ever wanted to link out to a non excel file on your computer or network drive?  This is the way I found to do it!
In Part II of this series, I will discuss how to identify all open instances of Excel and enumerate the workbooks, spreadsheets, and named ranges within each of those instances.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

738 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