View Full Version : Loop Through Subfolders And Copy Sheet
jmenche
09-16-2010, 08:28 AM
Howdy,
I have a folder that has about 20 subfolders. Each subfolder contains a spreadsheet. I have to keep it in the subfolder because it is linked to another spreadsheet in the same subfolder. A third party website where I pull data down makes me do this.
What I would like to do is loop through all of the subfolders and copy one sheet into a master workbook. Each file will ask to update links on opening and the sheet in question will have to be range valued before copying. Ultimately, I would have one workbook with 20 static sheets.
I am good with code in a file but not so good in the file directory.
Can someone help?
:beerchug:
...Each subfolder contains a spreadsheet...
You could use Dir I believe. As it sounds like there is only one workbook in ea subfolder, I included an Exit For after the first file is processed. I would have thought that I should be able to just grab the first .Item from .Files, but couldn't seem to.
Option Explicit
Sub exa()
Dim FSO As Object 'FileSystemObject
Dim fsoFile As Object ' File
Dim fsoFol As Object ' Folder
Dim FilNam As String
Const Path As String = "G:\2010\_Tmp\"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(Path$) Then
For Each fsoFol In FSO.GetFolder(Path$).SubFolders
For Each fsoFile In fsoFol.Files
If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xls" Then
MsgBox "open and copy from: " & fsoFile.Name
Exit For
End If
Next
Next
End If
End Sub
If you don't mind, I was wondering how the other thread worked out, as it was my first attempt at a Heap Sort.
jmenche
09-16-2010, 11:05 AM
GTO,
Thanks for the reply. I believe this gets me halfway. I still do not know how to copy a sheet from the fsoFile into a master sheet. The fsoFile did not support the Open command either.
I appreciate your post on my other thread. I had already taken care of my problem another way. Honestly, your post looks wayyyyy over my head. If have to be careful what I ask for. I just might get it!!
Thanks again
Thanks for the reply. I believe this gets me halfway. I still do not know how to copy a sheet from the fsoFile into a master sheet. The fsoFile did not support the Open command either.
Sorry - my bad. Try this. Not an end solution, more at getting into FSO so that you can use the properties to solve.
Option Explicit
Sub exa1()
Dim FSO As Object ' FileSystemObject
Dim fsoFile As Object ' File
Dim fsoFol As Object ' Folder
Dim strFilNam As String
Dim wb As Workbook
Const PATH As String = "D:\2010\_Tmp\"
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(PATH$) Then
For Each fsoFol In FSO.GetFolder(PATH$).SubFolders
For Each fsoFile In fsoFol.Files
If Mid(fsoFile.Name, InStrRev(fsoFile.Name, ".") + 1) = "xls" Then
If MsgBox("open and copy from: " & fsoFile.Name & "?", _
vbYesNo, vbNullString) = vbYes Then
Set wb = Workbooks.Open(fsoFile.PATH, , True)
wb.Worksheets(1).Copy _
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
wb.Close False
End If
Exit For
End If
Next
Next
End If
End Sub
As you will notice, FSO will return the properties of the file(s) and folder(s), so you can use the file's Path property (FullName) to open the file(s).
I appreciate your post on my other thread. I had already taken care of my problem another way. Honestly, your post looks wayyyyy over my head. If have to be careful what I ask for. I just might get it!!
Could you post your solution in the other thread? Thanks, as I was interested in solutions for that many combintions.
Mark
jmenche
09-20-2010, 11:14 AM
GTO,
For my other thread, I never found a way to sort and take the top 20. I also had to build a separate sub for each combination of items. Here is one.
Thanks for your ideas.
Sub TURF2()
Dim varData, varItems, varResults(1000000, 5) As String
Dim LastRow As Long, LastColumn As Long, i As Long, j As Long, k As Long, z As Long
Dim Reach As Double, Freq As Double, FreqShap As Double, x As Double
Dim ws As Worksheet, ws2 As Worksheet
Dim Shapley1 As Double, Shapley2 As Double
Set ws = ThisWorkbook.Sheets("Data")
Set ws2 = ThisWorkbook.Sheets("Results2")
LastRow = ws.Range("A65536").End(xlUp).Row
LastColumn = ws.Range("IV1").End(xlToLeft).Column
varData = ws.UsedRange
varItems = ws.Range("A2:A" & LastColumn).Value
x = 0
For j = 2 To LastColumn
For k = j + 1 To LastColumn
Reach = 0
Freq = 0
Shapley1 = 0
Shapley2 = 0
For i = 2 To LastRow
FreqShap = 0
If varData(i, j) < 3 Or varData(i, k) < 3 Then Reach = Reach + 1
If varData(i, j) < 3 Then
Freq = Freq + 1
FreqShap = FreqShap + 1
End If
If varData(i, k) < 3 Then
Freq = Freq + 1
FreqShap = FreqShap + 1
End If
If varData(i, j) < 3 Then Shapley1 = Shapley1 + (1 / FreqShap)
If varData(i, k) < 3 Then Shapley2 = Shapley2 + (1 / FreqShap)
Next
x = x + 1
varResults(x, 1) = varData(1, j) & "/" & varData(1, k)
varResults(x, 2) = Reach / (LastRow - 1)
varResults(x, 3) = Freq / Reach
varResults(x, 4) = Shapley1 / (LastRow - 1)
varResults(x, 5) = Shapley2 / (LastRow - 1)
Next
Next
ws2.Range("A2:E65536").ClearContents
For z = 1 To x
ws2.Cells(z + 1, 1) = varResults(z, 1)
ws2.Cells(z + 1, 2) = varResults(z, 2)
ws2.Cells(z + 1, 3) = varResults(z, 3)
ws2.Cells(z + 1, 4) = varResults(z, 4)
ws2.Cells(z + 1, 5) = varResults(z, 5)
Next
ws2.Range("A2:E65536").Sort Key1:=ws2.Range("C2"), Order1:=xlDescending
ws2.Range("A2:E65536").Sort Key1:=ws2.Range("B2"), Order1:=xlDescending
ws2.Columns("A:E").AutoFit
ws2.Columns("D:E").NumberFormat = "0%"
ws2.Columns("D:E").HorizontalAlignment = xlCenter
Set varData = Nothing
Set varItems = Nothing
End Sub
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.