caddman2001
New Member
- Joined
- Jul 27, 2013
- Messages
- 4
I am using Excel 2010, I have the file path + filename Column A (all excel files), file path Column B, file name Column C.
I need to paste multiple cell values from the list in column A into Columns D, E, F, G etc.
The VBA code for the file list is from this GREAT site:
Let strArr(i, 1) = strDir & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i)
Set fso = Nothing
If i > 0 Then
Range("A1").Resize(i).Value = strArr
End If
' Next, loop through all found files
' and break into path and filename
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To FinalRow
ThisEntry = Cells(i, 1)
For j = Len(ThisEntry) To 1 Step -1
If Mid(ThisEntry, j, 1) = Application.PathSeparator Then
Cells(i, 2) = Left(ThisEntry, j)
Cells(i, 3) = Mid(ThisEntry, j + 1)
Exit For
End If
Next j
Next i
End Sub
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.path & "\*.xls*")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.path & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i)
Next
End Sub
I would like to keep this as one macro and run a second macro to retrieve the values.
Thanks in advance!
Caddman2001
I need to paste multiple cell values from the list in column A into Columns D, E, F, G etc.
The VBA code for the file list is from this GREAT site:
Let strArr(i, 1) = strDir & strName
Let strName = Dir$()
Loop
Set fso = CreateObject("Scripting.FileSystemObject")
Call recurseSubFolders(fso.GetFolder(strDir), strArr(), i)
Set fso = Nothing
If i > 0 Then
Range("A1").Resize(i).Value = strArr
End If
' Next, loop through all found files
' and break into path and filename
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To FinalRow
ThisEntry = Cells(i, 1)
For j = Len(ThisEntry) To 1 Step -1
If Mid(ThisEntry, j, 1) = Application.PathSeparator Then
Cells(i, 2) = Left(ThisEntry, j)
Cells(i, 3) = Mid(ThisEntry, j + 1)
Exit For
End If
Next j
Next i
End Sub
Private Sub recurseSubFolders(ByRef Folder As Object, _
ByRef strArr() As String, _
ByRef i As Long)
Dim SubFolder As Object
Dim strName As String
For Each SubFolder In Folder.SubFolders
Let strName = Dir$(SubFolder.path & "\*.xls*")
Do While strName <> vbNullString
Let i = i + 1
Let strArr(i, 1) = SubFolder.path & strName
Let strName = Dir$()
Loop
Call recurseSubFolders(SubFolder, strArr(), i)
Next
End Sub
I would like to keep this as one macro and run a second macro to retrieve the values.
Thanks in advance!
Caddman2001