Solved

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

Posted on 2013-05-23
5
245 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
  • 3
  • 2
5 Comments
 
LVL 28

Expert Comment

by:omgang
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
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
Comment Utility
It's exactly what I wanted. Thank you!
0

Featured Post

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

INDEX and MATCH can be used to great effect to replace HLOOKUP and VLOOKUP as it does not have the limitation of needing the data to be sorted so that the reference value is in the first column or row. It also has the ability to perform a bi-directi…
Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
The viewer will learn how to simulate a series of sales calls dependent on a single skill level and learn how to simulate a series of sales calls dependent on two skill levels. Simulating Independent Sales Calls: Enter .75 into cell C2 – “skill leve…
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…

762 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

Need Help in Real-Time?

Connect with top rated Experts

11 Experts available now in Live!

Get 1:1 Help Now