Cell from Range, then set cell.value as Directory

[Rymare]

I have a userform that takes a mess of inputs from the user, and churns out a list of file paths for certain folders. You input a region, then a district (many districts in a region, then a city (there are many cities in a district), then the form lists all the atlases in that city (many atlases for a given city), then you pick from that list of atlases which ones you want, and then the form pastes the file path of only those selected atlases to a sheet in my excel.

Dim i As Integer

Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = True
    Next i
End If


If CheckBox1.Value = False Then
    For i = 0 To ListBox1.ListCount - 1
        ListBox1.Selected(i) = False
    Next i
End If


End Sub


Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
    For i = 0 To ListBox2.ListCount - 1
        ListBox2.Selected(i) = True
    Next i
End If


If CheckBox2.Value = False Then
    For i = 0 To ListBox2.ListCount - 1
        ListBox2.Selected(i) = False
    Next i
End If


End Sub


Private Sub CommandButton2_Click()
For i = 0 To ListBox1.ListCount - 1
    If ListBox1.Selected(i) = True Then ListBox2.AddItem ListBox1.List(i)
Next i
End Sub


Private Sub CommandButton3_Click()
Dim counter As Integer
counter = 0


For i = 0 To ListBox2.ListCount - 1
    If ListBox2.Selected(i - counter) Then
        ListBox2.RemoveItem (i - counter)
        counter = counter + 1
    End If
Next i


CheckBox2.Value = False
End Sub
Private Sub CommandButton4_Click()
Dim TheArray As Variant
Dim TheRange As Range
Dim FndList, x&


TheArray = ListBox2.List


Sheets("Output3").Activate
Sheets("Output3").Range("A:A").ClearContents


Set TheRange = Range(Cells(1, 1), Cells(UBound(TheArray) + 1, 1))


TheRange = TheArray


FndList = Sheets("Output1").Cells(1, 1).CurrentRegion


For x = 1 To UBound(FndList)
    Sheets("Output3").Range("a:a").Replace what:=FndList(x, 1), Replacement:=FndList(x, 2), LookAt:=xlWhole, MatchCase:=True
Next


Unload Me


'Call UserForm2
End Sub
Private Sub Frame1_Click()


End Sub


Private Sub Label1_Click()


End Sub


Private Sub CommandButton1_Click()


 Dim wb As Workbook
    Dim ws As Worksheet
    Dim objFSO As Object
    Dim objFolder As Object
    Dim objSubFolder As Object
    Dim Folder_Name As String


    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ""


    Set wb = ThisWorkbook
    Set wsControl = wb.Sheets("Control1"): Set wsOutput = wb.Sheets("Output1")
    Folder_Name = "C:\Users\AButler\OneDrive - Energy\User Folders\Desktop\Field Inspection\SLIP Packages Prepared\" & TextBox1.Value & "\" & TextBox2.Value & "\" & TextBox3.Value
    If TextBox1.Value = "" Then
        MsgBox "Region is not entered or is misspelled. Please (re)enter region"
        wsControl.Cells(1, 2).Select
        End
    End If
    If TextBox2.Value = "" Then
        MsgBox "District is not entered or is misspelled. Please (re)enter district"
        wsControl.Cells(1, 2).Select
        End
    End If
    If TextBox3.Value = "" Then
        MsgBox "City is not entered or is misspelled. Please (re)enter city"
        wsControl.Cells(1, 2).Select
        End
    End If
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(Folder_Name)


    i = 1
    Dim MyArr() As Variant
    ReDim MyArr(1 To i, 1 To 2)
    On Error GoTo CleanFail


    Application.EnableCancelKey = xlErrorHandler
    Const IterationsToUpdate As Integer = 10
    For Each objSubFolder In objFolder.subfolders
        MyArr(i, 1) = objSubFolder.Name
        MyArr(i, 2) = objSubFolder.Path
        i = i + 1
            MyArr = Application.Transpose(MyArr)
            ReDim Preserve MyArr(1 To 2, 1 To i)
            MyArr = Application.Transpose(MyArr)
        If i Mod IterationsToUpdate = 0 Then
            Application.StatusBar = objSubFolder.Path & " " & objSubFolder.Name
            DoEvents
        End If
    Next objSubFolder
    Application.StatusBar = ""


    wsOutput.Rows("2:1048576").Delete
    Dim Destination As Range
    Set Destination = wsOutput.Range("A2")
    Destination.Resize(UBound(MyArr, 1), UBound(MyArr, 2)).Value = MyArr
    wsOutput.Columns.EntireColumn.AutoFit: wsOutput.UsedRange.HorizontalAlignment = xlCenter
    wsOutput.Activate


    Application.StatusBar = "Folder Names Imported " & "Elapsed Time " & Format(Time - TStart1, "hh:mm:ss")
    ListBox1.List = Sheets("Output1").Range("a2:a" & Sheets("Output1").Cells(Rows.Count, 1).End(xlUp).Row).Value


CleanExit:
    Application.StatusBar = False
    Application.StatusBar = ""
    Application.Cursor = xlDefault
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Exit Sub


CleanFail:
    Const MsgTitle As String = "Operation not completed"
    If Err.Number = 18 Then
        MsgBox "Operation was cancelled.", vbInformation, MsgTitle
    Else
        MsgBox "An error has occurred: " & Err.Description, vbCritical, MsgTitle
    End If
    Resume CleanExit




End Sub


Private Sub Label2_Click()


End Sub


Private Sub ListBox1_Click()


End Sub


Private Sub ListBox2_Click()


End Sub


Private Sub OptionButton3_Click()
ListBox1.MultiSelect = 2
ListBox2.MultiSelect = 2
End Sub


Private Sub Region_Click()


End Sub


Private Sub TextBox1_Change()
'region
End Sub


Private Sub TextBox2_Change()
'district
End Sub


Private Sub TextBox3_Change()
'city
End Sub


Private Sub UserForm_Click()


End Sub


   
Private Sub UserForm_Initialize()
OptionButton3.Value = True
End Sub

The userform looks like this:

For example, I'm in the Inland Region working in the city of Menifee--which has 100 atlases splitting up the city, but I only want the file paths for atlases MNFE 1 and MNFE 5. This code lets me get that. In each atlas are many other folders named after Street, and in each Street folder is an excel that lists every address on that street.

What I'm TRYING to do is then set that list of file paths (the atlases file paths) created at the end of my user form as a range, and for each cell in that range, use the cell value (which is a file path), as a directory that will be searched (each street folder in the given atlas folder) for excel files. The code will then take all those excel files--which lists all the addresses on that street and are all in the exact same format--and copy the excel file's rows into a new workbook.

This would look until every cell in the range is searched and ending with one new workbook that has one sheet, with one long list of addresses.



I have no idea if this makes sense, or is even possible. I have been attempting to do this for a while and the closest I think I've come is this code that is orig. meant to change a cell color (that I modified a little--not that my mods work or anything). Source included in code:

Sub LoopAllExcelFilesInFolder()'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com


Dim wb As Workbook
Dim atlas as Range: set atlas= sheets("Output3").Range("A:A")
Dim cell as Range
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog


'Optimize Macro Speed
  Application.ScreenUpdating = False
  Application.EnableEvents = False
  Application.Calculation = xlCalculationManual

For each cell in atlas
if cell.value=""
Then
'do nothing
Else
Cell.value=mypath


'In Case of Cancel
NextCode:
  myPath = myPath
  If myPath = "" Then GoTo ResetSettings


'Target File Extension (must include wildcard "*")
  myExtension = "*.xls*"


'Target Path with Ending Extention
  myFile = Dir(myPath & myExtension)


'Loop through each Excel file in folder
  Do While myFile <> ""
    'Set variable equal to opened workbook
      Set wb = Workbooks.Open(Filename:=myPath & myFile)
    
    'Ensure Workbook has opened before moving on to next line of code
      DoEvents
    
    'Change
      wb.Worksheets(1).Range("A1:Z1").Interior.Color = RGB(51, 98, 174)
    
    'Save and Close Workbook
      wb.Close SaveChanges:=True
      
    'Ensure Workbook has closed before moving on to next line of code
      DoEvents


    'Get next file name
      myFile = Dir
  Loop


'Message Box when tasks are completed
  MsgBox "Task Complete!"


ResetSettings:
  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End if
Next cell


End Sub

And I've tried to hybridize it with this code.

Any help is much appreciated, and if it's a confusing let me know I can add pictures, I just want to figure this out.

 

[Rymare]

I tried to put my list of filepaths in an array, then loop through the array and I know already that it's all messed up but I just want to know if I'm even close to the right idea:

Sub idkanymore()

Dim lStudentCount As Long
    lStudentCount = Sheets("Output3").Range("A" & Rows.Count).End(xlUp).Row


    ' Create array of correct size
Dim arr() As String
ReDim arr(1 To lStudentCount)
Dim element As Variant
Dim strFolder As String, strFile As String


For Each element In arr
    element.Value = strFolder
    strFile = Dir(strFolder & "*.xlsx")
    lngNextRow = 11
    Do While Len(strFile) > 0
        Set wbSource = Workbooks.Open(fileName:=strFolder & strFile)
        Set wsSource = wbSource.Worksheets(1)
        lngRowCount = wsSource.UsedRange.Rows.Count
        wsDest.Cells(lngNextRow, "A").Value = lngRowCount
        wbSource.Close savechanges:=False
        lngNextRow = lngNextRow + 1
        strFile = Dir
    Loop
Next element
End Sub

 

[Rymare]

If anyone is interested, I asked this question on StackOverflow when I could not get an answer here, and this is the solution the amazing Zev Spitz came up with. He is a legend.

Option Explicit
Sub GetExcelFilesByType()
    Dim ws2 As Worksheet: Set ws2 = Sheets("Output3")
    Dim allFiles As Collection
    Set allFiles = GetFiles(Sheets("Output3").Range("A1", Sheets("Output3").Range("A1").End(xlDown)))
    Dim excelFiles As New Collection
    Dim file As Scripting.file
    For Each file In allFiles
        If file.Type = "Microsoft Excel Worksheet" Then excelFiles.Add file
    Next


Dim r As Integer
Dim c As Integer
Dim item As Variant
r = 1
c = 1
For Each item In excelFiles
    ThisWorkbook.Worksheets("ghgh").Cells(r, c).Value = item
    r = r + 1
Next item


End Sub


' Or you could filter by extension, using the FileSystemObject.GetExtensionName method
Sub GetExcelFilesByExtensionName()
    Dim ws2 As Worksheet: Set ws2 = Sheets("Output3")
    Dim allFiles As Collection
    Set allFiles = GetFiles(ws2.Range("A1:A" & Rows.Count).End(xlUp)) 'from question


    Dim excelFiles As New Collection
    Dim fso As New Scripting.FileSystemObject
    Dim file As Scripting.file
    For Each file In allFiles
        Select Case fso.GetExtensionName(file.path)
            Case "xls", "xlsb", "xlsm"
                excelFiles.Add file
        End Select
    Next
End Sub
Public Function GetFiles(roots As Variant) As Collection
    Select Case TypeName(roots)
        Case "String", "Folder"
            roots = Array(roots)
    End Select


    Dim results As New Collection
    Dim fso As New Scripting.FileSystemObject


    Dim root As Variant
    For Each root In roots
        AddFilesFromFolder fso.GetFolder(root), results
    Next


    Set GetFiles = results
End Function
Sub AddFilesFromFolder(folder As Scripting.folder, results As Collection)
    Dim file As Scripting.file
    For Each file In folder.Files
        results.Add file
    Next


    Dim subfolder As Scripting.folder
    For Each subfolder In folder.SubFolders
        AddFilesFromFolder subfolder, results
    Next
End Sub