PDA

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:

GTO
09-16-2010, 09:59 AM
...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

GTO
09-16-2010, 02:41 PM
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