Adding User Input to a collection (path of folder they want to search), then looping through each item with For-Each.

[jcoleman25]

I'm having a hard time getting this collection thing down. What I want this code to do is take the user input as a string and store it for use later when the For-Each code is run. I'm not having any luck so far and its probably because I'm having trouble wrapping my head around the concept.

Obviously once I figure out how to add to the collection I can skip the first folder it asks for and just do the collection. As I told a friend of mine once I got it to search 2 folders- "Its a feature, not a bug."

When I've run it like this it either puts the MultiPath in the collection and then overwrites it with the next...

Or

It just ignores that bit and Multipath remains the string that was entered?

For instance, if I enter folder A in the first user input section, then Z and X in the collection, I get A and X but not Z in the output.

Dim Cancel As Boolean
Dim FolderPath, PartNoColumn, FirstPart
Dim Multi As Boolean
Public MultiPaths As Collection
Dim Multipath As String
Sub BOMHyperlinks()
Cancel = False
Multi = False
BH2_Setup
If Cancel = True Then Exit Sub
Add_Links FolderPath, PartNoColumn, FirstPart                    'code to search and return hyperlinks
If Multi = True Then
    For Each Item In MultiPaths
        FolderPath = Multipath
            BH4_Add_Links FolderPath, PartNoColumn, FirstPart    ' code to search and return hyperlinks
    Next
End If
Set MultiPaths = Nothing
End Sub
Sub BH3_MultiPath()
On Error GoTo MultiErrorHandle
MorePaths:
Multipath = InputBox("Please enter the path of the additional folder you wish to search: ")
Set PathCheck = CreateObject("Scripting.FileSystemObject")
Set folder = PathCheck.getfolder(Multipath)
MultiPaths.Add Multipath
Select Case MsgBox("Any More?", vbYesNo)
    Case vbYes
        GoTo MorePaths
    Case vbNo
        Multi = True
End Select
Exit Sub
MultiErrorHandle:
Select Case Err.Number
    Case 76
        If MsgBox("That is not a valid file path." & vbCrLf & "Try again?", vbYesNo) _
    = vbNo Then Exit Sub Else: _
        Resume MorePaths
    Case 5
        If MsgBox("Sorry, without a folder I cannot continue." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Exit Sub Else: _
          Resume MorePaths
End Select
MsgBox ("Something unexpected has happened. This program will end." & vbCrLf & _
"Please write down this error number for debugging and program improvement." & vbCrLf & _
"The error number is " & Err.Number)
Cancel = True
End Sub

Sub BH2_Setup()

Dim TrimRange As Range
Dim TrimCell As Range
'get user input
      
ResumePath:
On Error GoTo ErrorHandle
FolderPath = InputBox("Please enter the path of the folder you wish to search: ")
Set PathCheck = CreateObject("Scripting.FileSystemObject")
Set folder = PathCheck.getfolder(FolderPath)
Select Case MsgBox("Is there another folder that you'd like to search?", vbYesNo)
    Case Is = vbYes
        On Error GoTo 0
        BH3_MultiPath
        
    Case Is = vbNo
        ContinueProcedure = True
End Select

    
  
ResumeColumn:
On Error GoTo ErrorHandle
PartNoColumn = InputBox("Enter the column that the part numbers are in: ")
Range(PartNoColumn & "1").Select
ResumeFirstPart:
On Error GoTo ErrorHandleRow
FirstPart = InputBox("Enter the row that the first part number is in: ")
Range(PartNoColumn & FirstPart).Select
On Error GoTo 0
Set TrimRange = Range(PartNoColumn & FirstPart & ":" & PartNoColumn & ActiveSheet.UsedRange.Rows.Count)
   For Each TrimCell In TrimRange
    TrimCell = Trim(TrimCell)
    Next TrimCell
Exit Sub
'folder and column error handling
ErrorHandle:
Select Case Err.Number
    Case 76
        If MsgBox("That is not a valid file path." & vbCrLf & "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else: _
        Resume ResumePath
    Case 5
        If MsgBox("Sorry, without a folder I cannot continue." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else: _
          Resume ResumePath
    Case 1004
        If MsgBox("That is not a valid column." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else: _
          Resume ResumeColumn
End Select
GoTo UnknownError
'row error handling
ErrorHandleRow:
Select Case Err.Number
    Case 1004
        If MsgBox("That is not a valid row." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else _
        Resume ResumeFirstPart
End Select
GoTo UnknownError
Exit Sub
'unknown error handling
UnknownError:
MsgBox ("Something unexpected has happened. This program will end." & vbCrLf & _
"Please write down this error number for debugging and program improvement." & vbCrLf & _
"The error number is " & Err.Number)

End Sub

Thanks to Al Chara for helping me with the code you don't see here.
That thread is:
Return Hyperlink for Corresponding File from a List on Worksheet.

 

[tweedle]

Is there something elsewhere that is creating the MultiPaths collection?

You're looking to gather a list of paths to have some 'seek & report' process performed, correct?

 

[tweedle]

Here's a slightly different perspective on building a collection of paths:

Const msg1 = "Collect Paths to search by selecting them in the following dialogs. " & vbLf & _
    "Don't worry, we're keeping track of them for you." & vbLf & _
    "Press Cancel when you're done."


Public MultiPaths As Collection
Dim Paths As New Collection
Dim strPath As String


Sub CreatePathCollection()


    'Initiate variables
    strPath = "C:\"
    strPath = myDocuments()
    
    'Advise user what to expect, and how to use.
    MsgBox msg1
    
    'Loop for folders and store selected until Cancel is pressed on the dialog
    Do
        retval = GetFolder(strPath)
        If retval <> "" Then
            Paths.Add retval & "\", retval & "\"
        End If
    Loop While retval <> ""
    
    'Report what's in Paths collection
    out$ = ""
    For i = 1 To Paths.Count
        out$ = out$ & Paths.Item(i) & vbLf
    Next i
    MsgBox "You selected: " & vbLf & out$
    
    'Copy Paths to Multipaths
    Set MultiPaths = Paths
    
    'Report what's in Multipaths collection
    out$ = ""
    For i = 1 To Paths.Count
        out$ = out$ & MultiPaths.Item(i) & vbLf
    Next i
    MsgBox "We stored: " & vbLf & out$
    
End Sub
Function GetFolder(strPath As String) As String
' Provides a built-in dialog to select a folder
' Courtesy of Richard Schollar:
' http://www.mrexcel.com/forum/excel-questions/294728-browse-folder-visual-basic-applications.html


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 myDocuments()
    'Returns the 'My Documents' folder for the user
    Dim WSHShell As Object
    Set WSHShell = CreateObject("Wscript.Shell")
    myDocuments = WSHShell.SpecialFolders("MyDocuments")
    Set WSHShell = Nothing
End Function

 

[jcoleman25]

Correct, to answer your second question, tweedle. As for your first question, I thought that's what I was doing with the Dim Multipaths as New Collection (mimicking what Al Chara did with the MyFiles. Here's the full code that is "working". It takes the first path entered and then asks for any more. Here the user can enter one more path but adding a second additional path (via a loop I've removed/commented out) would just overwrite the previous entry in that section. I'll have a chance tonight or tomorrow to look at the code you posted.
Thanks.

'Last Updated 2-6-13 by John Coleman
Dim MyFiles As New Collection
Dim Cancel As Boolean
Dim FolderPath, PartNoColumn, FirstPart
Dim Multi As Boolean
Dim MultiPaths As New Collection
Dim MultiPath As String


Sub BOMHyperlinks()
Cancel = False
Multi = False
BH1_Save
If Cancel = True Then Exit Sub
BH2_Setup
If Cancel = True Then Exit Sub
Add_Links FolderPath, PartNoColumn, FirstPart
If Multi = True Then
    For Each Item In MultiPaths
        FolderPath = MultiPath
            BH4_Add_Links FolderPath, PartNoColumn, FirstPart
    Next
End If
Set MultiPaths = Nothing
End Sub


Private Sub BH1_Save()
Select Case MsgBox("Hello. Actions taken by this program cannot be undone." & vbCrLf & _
      "Would you like to save this workbook first?.", vbYesNoCancel)
       Case vbYes
       ThisWorkbook.Save
       Case vbCancel
             Cancel = True
             
       End Select
End Sub


Private Sub BH3_MultiPath()
On Error GoTo MultiErrorHandle
MorePaths:
MultiPath = InputBox("Please enter the path of the additional folder you wish to search: ")
Set PathCheck = CreateObject("Scripting.FileSystemObject")
Set folder = PathCheck.getfolder(MultiPath)
MultiPaths.Add MultiPath
Multi = True
MsgBox ("For now, I can only search two folders at a time.")

'Select Case MsgBox("Any More?", vbYesNo)
'    Case vbYes
'        p = p + 1
'        GoTo MorePaths
'    Case vbNo
'        Multi = True
'End Select
'Set fso = CreateObject("Scripting.FileSystemObject")
'    Set folder = fso.getfolder(MyPath)
'    If counter = 0 Then
'        For Each file In folder.Files
'            MyFiles.Add Array(file, file.Name)
MultiErrorHandle:
Select Case Err.Number
    Case 76
        If MsgBox("That is not a valid file path." & vbCrLf & "Try again?", vbYesNo) _
    = vbNo Then Exit Sub Else: _
        Resume MorePaths
    Case 5
        If MsgBox("Sorry, without a folder I cannot continue." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Exit Sub Else: _
          Resume MorePaths
End Select
End Sub


Private Sub BH2_Setup()

Dim TrimRange As Range
Dim TrimCell As Range
'get user input
      
ResumePath:
On Error GoTo ErrorHandle
FolderPath = InputBox("Please enter the path of the folder you wish to search: ")
Set PathCheck = CreateObject("Scripting.FileSystemObject")
Set folder = PathCheck.getfolder(FolderPath)
Select Case MsgBox("Is there another folder that you'd like to search?", vbYesNo)
    Case Is = vbYes
        On Error GoTo 0
        BH3_MultiPath
        
    Case Is = vbNo
        ContinueProcedure = True
End Select
ResumeColumn:
On Error GoTo ErrorHandle
PartNoColumn = InputBox("Enter the column that the part numbers are in: ")
Range(PartNoColumn & "1").Select
ResumeFirstPart:
On Error GoTo ErrorHandleRow
FirstPart = InputBox("Enter the row that the first part number is in: ")
Range(PartNoColumn & FirstPart).Select
On Error GoTo 0
Set TrimRange = Range(PartNoColumn & FirstPart & ":" & PartNoColumn & ActiveSheet.UsedRange.Rows.Count)
   For Each TrimCell In TrimRange
    TrimCell = Trim(TrimCell)
    Next TrimCell
'go to the ADD_Links Sub
'Add_Links FolderPath, PartNoColumn, FirstPart
Exit Sub
'folder and column error handling
ErrorHandle:
Select Case Err.Number
    Case 76
        If MsgBox("That is not a valid file path." & vbCrLf & "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else: _
        Resume ResumePath
    Case 5
        If MsgBox("Sorry, without a folder I cannot continue." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else: _
          Resume ResumePath
    Case 1004
        If MsgBox("That is not a valid column." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else: _
          Resume ResumeColumn
End Select
Exit Sub
'row error handling
ErrorHandleRow:
Select Case Err.Number
    Case 1004
        If MsgBox("That is not a valid row." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else _
        Resume ResumeFirstPart
End Select
Exit Sub
'unknown error handling
MsgBox ("Something unexpected has happened. This program will end." & vbCrLf & _
"Please write down this error number for debugging and program improvement." & vbCrLf & _
"The error number is " & Err.Number)

End Sub


Private Sub Add_Links(FolderPath, PartNoColumn, FirstPart)
'dimensions
Dim CellRange As String
Dim rngPartList As Range
Dim rngPartNo As Range
Dim i As Long
Dim j As Long
Debug.Print FolderPath
Application.ScreenUpdating = False
''insert column next to part numbers
'If Multi = False Then
Range(PartNoColumn & ":" & PartNoColumn).Offset(0, 1).Insert
'set CellRange
CellRange = PartNoColumn & FirstPart & ":" & PartNoColumn & ActiveSheet.UsedRange.Rows.Count
'set rngPartList
Set rngPartList = ActiveSheet.Range(CellRange)
FileList FolderPath, 0
    
For Each rngPartNo In rngPartList
   If rngPartNo.Value = "" Then GoTo BlankCell
      j = 0
        For i = 1 To MyFiles.Count
          If InStr(1, MyFiles.Item(i)(1), rngPartNo, vbTextCompare) > 0 Then
            If rngPartNo.Cells.Offset(j, 1).Value <> "" Then j = j + 1
              If j > 0 Then Rows(rngPartNo.Row + j).Insert
                ActiveSheet.Hyperlinks.Add Anchor:=rngPartNo.Offset(j, 1), Address:=MyFiles.Item(i)(0), TextToDisplay:=MyFiles.Item(i)(1)
            End If
        Next i
BlankCell:
    Next rngPartNo
    Set MyFiles = Nothing
    
Columns(PartNoColumn & ":" & PartNoColumn).Offset(0, 1).AutoFit
    
End Sub


Private Sub FileList(MyPath, counter)               'MyPath = FolderPath
'Debug.Print MyPath
'Dim MyFiles As New Collection
'Dim Cancel As Boolean
'Dim FolderPath, PartNoColumn, FirstPart
'Dim Multi As Boolean
'Dim MultiPaths As New Collection
'Dim MultiPath As String
Dim fso, folder, SubFolders, subfolder, file
    
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.getfolder(MyPath)
    If counter = 0 Then
        For Each file In folder.Files
            MyFiles.Add Array(file, file.Name)
            
            
        Next file
    End If
    Set SubFolders = folder.SubFolders
    For Each subfolder In SubFolders
        For Each file In subfolder.Files
            MyFiles.Add Array(file, file.Name)
        
        Next file
        FileList subfolder, 1
    Next
    
    
End Sub


Private Sub BH4_Add_Links(FolderPath, PartNoColumn, FirstPart)
'dimensions
Dim CellRange As String
Dim rngPartList As Range
Dim rngPartNo As Range
Dim i As Long
Dim j As Long
Debug.Print FolderPath
Application.ScreenUpdating = False
''insert column next to part numbers
'If Multi = False Then
 '   Range(PartNoColumn & ":" & PartNoColumn).Offset(0, 1).Insert
'set CellRange
CellRange = PartNoColumn & FirstPart & ":" & PartNoColumn & ActiveSheet.UsedRange.Rows.Count
'set rngPartList
Set rngPartList = ActiveSheet.Range(CellRange)
BH5_File_List FolderPath, 0
    
For Each rngPartNo In rngPartList
   If rngPartNo.Value = "" Then GoTo BlankCell
      j = 0
        For i = 1 To MyFiles.Count
          If InStr(1, MyFiles.Item(i)(1), rngPartNo, vbTextCompare) > 0 Then
            If rngPartNo.Cells.Offset(j, 1).Value <> "" Then j = j + 1
              If j > 0 Then Rows(rngPartNo.Row + j).Insert
                ActiveSheet.Hyperlinks.Add Anchor:=rngPartNo.Offset(j, 1), Address:=MyFiles.Item(i)(0), TextToDisplay:=MyFiles.Item(i)(1)
            End If
        Next i
BlankCell:
    Next rngPartNo
    Set MyFiles = Nothing
    
Columns(PartNoColumn & ":" & PartNoColumn).Offset(0, 1).AutoFit
    
End Sub


Private Sub BH5_File_List(MyPath, counter)
'Debug.Print MyPath
Dim fso, folder, SubFolders, subfolder, file
    
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.getfolder(MyPath)
    If counter = 0 Then
        For Each file In folder.Files
            MyFiles.Add Array(file, file.Name)
            
            
        Next file
    End If
    Set SubFolders = folder.SubFolders
    For Each subfolder In SubFolders
        For Each file In subfolder.Files
            MyFiles.Add Array(file, file.Name)
        
        Next file
        FileList subfolder, 1
    Next
    
    
End Sub

 

[tweedle]

You are correct;
Dim MultiPaths As New Collection
will create the collection object.

Dim MultiPaths As Collection (as in the first post) would need some additional create operation to actually create the collection.

Dim MultiPaths As New Collection will work.

 

[jcoleman25]

Thanks for the help. I've just been working on it. I was able to get your code to feed into the earlier code. I'll study it more later to better figure out how it works but for now I'm going through and cleaning up the unnecessary duplications. Post code soon.

 

[jcoleman25]

Code. Needs some bells and whistles but it works

Public Multipaths As Collection
Dim Paths As New Collection
Dim strPath As String
Dim MyFiles As New Collection
Dim Cancel As Boolean
Dim FolderPath, PartNoColumn, FirstPart
Dim Multi As Boolean

Sub BOMHyperlinks()
Cancel = False
Multi = False
BH1_Save
If Cancel = True Then Exit Sub
CreatePathCollection
If Cancel = True Then Exit Sub
BH2_Setup
If Cancel = True Then Exit Sub
    
For p = 1 To Multipaths.Count
    If Multipaths.Count > 1 Then Multi = True
        FolderPath = Multipaths.Item(p)
        
Add_Links FolderPath, PartNoColumn, FirstPart
    If Multipaths.Count > 1 Then Multi = True
Next p
MsgBox ("All done!")
End Sub

Private Sub BH1_Save()
Select Case MsgBox("Hello. Actions taken by this program cannot be undone." & vbCrLf & _
      "Would you like to save this workbook first?.", vbYesNoCancel)
       Case vbYes
       ThisWorkbook.Save
       
       Case vbCancel
             Cancel = True
End Select
End Sub

Private Sub CreatePathCollection()
'Initiate variables
strPath = "C:\"
strPath = myDocuments()
'Loop for folders and store selected until Cancel is pressed on the dialog
Do
retval = GetFolder(strPath)
    If retval <> "" Then
        Paths.Add retval & "\", retval & "\"
    End If
Loop While retval <> ""
    
'Report what's in Paths collection
out$ = ""
For i = 1 To Paths.Count
    out$ = out$ & Paths.Item(i) & vbLf
Next i
MsgBox "You selected: " & vbLf & out$
    
'Copy Paths to Multipaths
Set Multipaths = Paths
    
'Report what's in Multipaths collection
out$ = ""
For i = 1 To Paths.Count
    out$ = out$ & Multipaths.Item(i) & vbLf
Next i
MsgBox "We stored: " & vbLf & out$
    
'BOMHyperlinks Multipaths
    
End Sub

Function GetFolder(strPath As String) As String
' Provides a built-in dialog to select a folder
' Courtesy of Richard Schollar:
' [URL]http://www.mrexcel.com/forum/excel-questions/294728-browse-folder-visual-basic-applications.html[/URL]
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 myDocuments()
    'Returns the 'My Documents' folder for the user
    Dim WSHShell As Object
    Set WSHShell = CreateObject("Wscript.Shell")
    myDocuments = WSHShell.SpecialFolders("MyDocuments")
    Set WSHShell = Nothing
End Function
 
Private Sub BH2_Setup()
Dim TrimRange As Range
Dim TrimCell As Range
ResumeColumn:
On Error GoTo ErrorHandle
PartNoColumn = InputBox("Enter the column that the part numbers are in: ")
Range(PartNoColumn & "1").Select
ResumeFirstPart:
On Error GoTo ErrorHandleRow
FirstPart = InputBox("Enter the row that the first part number is in: ")
Range(PartNoColumn & FirstPart).Select
On Error GoTo 0
Set TrimRange = Range(PartNoColumn & FirstPart & ":" & PartNoColumn & ActiveSheet.UsedRange.Rows.Count)
    For Each TrimCell In TrimRange
        TrimCell = Trim(TrimCell)
    Next TrimCell
Exit Sub
'folder and column error handling
ErrorHandle:
Select Case Err.Number
    Case 1004
        If MsgBox("That is not a valid column." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else: _
          Resume ResumeColumn
End Select
Exit Sub
'row error handling
ErrorHandleRow:
Select Case Err.Number
    Case 1004
        If MsgBox("That is not a valid row." & vbCrLf & _
        "Try again?", vbYesNo) _
    = vbNo Then Cancel = True Else _
        Resume ResumeFirstPart
End Select
Exit Sub
'unknown error handling
MsgBox ("Something unexpected has happened. This program will end." & vbCrLf & _
"Please write down this error number for debugging and program improvement." & vbCrLf & _
"The error number is " & Err.Number)

End Sub

Private Sub Add_Links(FolderPath, PartNoColumn, FirstPart)
'dimensions
Dim CellRange As String
Dim rngPartList As Range
Dim rngPartNo As Range
Dim i As Long
Dim j As Long
Debug.Print FolderPath
Application.ScreenUpdating = False
''insert column next to part numbers
If Multi = False Then
  Range(PartNoColumn & ":" & PartNoColumn).Offset(0, 1).Insert
End If
'set CellRange
CellRange = PartNoColumn & FirstPart & ":" & PartNoColumn & ActiveSheet.UsedRange.Rows.Count
'set rngPartList
Set rngPartList = ActiveSheet.Range(CellRange)
FileList FolderPath, 0
    
For Each rngPartNo In rngPartList
   If rngPartNo.Value = "" Then GoTo BlankCell
      j = 0
        For i = 1 To MyFiles.Count
          If InStr(1, MyFiles.Item(i)(1), rngPartNo, vbTextCompare) > 0 Then
            If rngPartNo.Cells.Offset(j, 1).Value <> "" Then j = j + 1
              If j > 0 Then Rows(rngPartNo.Row + j).Insert
                ActiveSheet.Hyperlinks.Add Anchor:=rngPartNo.Offset(j, 1), Address:=MyFiles.Item(i)(0), TextToDisplay:=MyFiles.Item(i)(1)
          End If
            Next i
BlankCell:
    Next rngPartNo
    Set MyFiles = Nothing
    
Columns(PartNoColumn & ":" & PartNoColumn).Offset(0, 1).AutoFit
    
End Sub

Private Sub FileList(MyPath, counter)
Dim fso, folder, SubFolders, subfolder, file
    
    On Error Resume Next
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(MyPath)
    If counter = 0 Then
        For Each file In folder.Files
            MyFiles.Add Array(file, file.Name)
            
            
        Next file
    End If
    Set SubFolders = folder.SubFolders
    For Each subfolder In SubFolders
        For Each file In subfolder.Files
            MyFiles.Add Array(file, file.Name)
        Debug.Print file
        Next file
        FileList subfolder, 1
    Next
    
End Sub