PDA

View Full Version : Data Mining from Multiple Files



MrRhodes2004
02-19-2008, 03:50 PM
I have multiple files in a folder which I would like to extract data. The files have the same format and data is in same location in each file. The number of files will vary each time.

Code:
For each file in folder
open file
copy/select cells
paste cells in active workbook
determine file name - insert in cell
close file
next

I'm not sure where to start with this. I'm sure it is pretty simple since data mining is used all the time. I just don't know...

This is what I have found so far...
Sub ProcessFiles()
Dim FSO As Object
Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")

sFolder = "U:\Houston Metro\MDX\Summaries"
If sFolder <> "" Then
Set Folder = FSO.GetFolder(sFolder)

Set Files = Folder.Files
For Each file In Files
Workbooks.Open Filename:=file.Path
With ActiveWorkbook

End With
Next file

End If ' sFolder <> ""
Application.ScreenUpdating = True
End Sub

Bob Phillips
02-19-2008, 05:25 PM
Where is the data in the target workbook?

Where in the existing workbook do you want to store it?

Where do you want to put the filename?

MrRhodes2004
02-20-2008, 08:08 AM
Thanks Xld...

I've attached an xls file. Since I'm only allowed to upload one file, I combined the the source and the destination.

The source data is located in the "Output Summary" sheets of each file to be opened. The particular information has been highlighted with colors.

The destination of the data is the "Data Collection" of the FileProcess.xls. Each file in the folder has 12 pieces of data plus the file name which will be placed on one row.

I hope this makes sense. If not, let me know.

I've played with the code a little as you can see but didn't get too far.

MrRhodes2004
02-20-2008, 08:52 AM
This is where I have the code - it seems to work fine but there has to be a smoother or more elegant method to accomplish this... (yes, I know, I need to clean up the code and get rid of the garbage in it...)

Sub ProcessFiles()
Dim FSO As Object
'Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object
Dim actWb As Object
Dim Copy1
Dim wsData
Dim Results As Range
Dim i
Dim wb As Workbook
Dim FileName
Set actWb = ActiveWorkbook
Set wsData = ActiveSheet
i = 3
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")

sFolder = "U:\Houston Metro\MDX\Summaries"
If sFolder <> "" Then
Set Folder = FSO.GetFolder(sFolder)

Set Files = Folder.Files
For Each file In Files
Workbooks.Open FileName:=file.Path, ReadOnly:=True
Set wb = ActiveWorkbook
With wb
Sheets("Output Summary").Select
Range("D16:D18").Select
Selection.Copy
actWb.Activate
Cells(i, 2).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

wb.Activate
Sheets("Output Summary").Select
Range("E16:E18").Select
Selection.Copy
actWb.Activate
Cells(i, 5).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

wb.Activate
Sheets("Output Summary").Select
Range("D31:D33").Select
Selection.Copy
actWb.Activate
Cells(i, 8).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True


wb.Activate
Sheets("Output Summary").Select
Range("E31:E33").Select
Selection.Copy
actWb.Activate
Cells(i, 11).Select
Selection.PasteSpecial Paste:=xlPasteValues, Transpose:=True

FileName = wb.Name
Cells(i, 14) = FileName

End With


wb.Close
actWb.Activate
i = i + 1
Next file

End If ' sFolder <> ""
Application.ScreenUpdating = True
End Sub

Bob Phillips
02-20-2008, 09:09 AM
Apart from the tidying-up, and it works, what more do you want?



Sub ProcessFiles()
Dim FSO As Object
'Dim i As Long
Dim sFolder As String
Dim fldr As Object
Dim Folder As Object
Dim file As Object
Dim Files As Object
Dim actWb As Workbook
Dim Results As Range
Dim i As Long
Dim wb As Workbook
Dim FileName

Set actWb = ActiveWorkbook
i = 3
Application.ScreenUpdating = False
Set FSO = CreateObject("Scripting.FileSystemObject")

sFolder = "U:\Houston Metro\MDX\Summaries"
If sFolder <> "" Then
Set Folder = FSO.GetFolder(sFolder)

Set Files = Folder.Files
For Each file In Files
Workbooks.Open FileName:=file.Path, ReadOnly:=True
Set wb = ActiveWorkbook
With wb
.Sheets("Output Summary").Range("D16:D18").Copy actWb.Cells(i, 2)

.Sheets("Output Summary").Range("E16:E18").Copy actWb.Cells(i, 5)

.Sheets("Output Summary").Range("D31:D33").Copy actWb.Cells(i, 8)

.Sheets("Output Summary").Range("E31:E33").Copy actWb.Cells(i, 11)

actWb.Cells(i, 14) = wb.Name
End With

wb.Close
actWb.Activate
i = i + 1
Next file

End If ' sFolder <> ""
Application.ScreenUpdating = True
End Sub

MrRhodes2004
02-20-2008, 09:35 AM
Apart from the tidying-up, and it works, what more do you want?



.Sheets("Output Summary").Range("D16:D18").Copy actWb.Cells(i, 2)



That is what I was looking for. That is much cleaner than what I had but the copied data needs to be transposed. How do you modify what you have to transpose the copied info?

Bob Phillips
02-20-2008, 10:45 AM
Oops I missed the transpose, the best you can do is like so



Sheets("Output Summary").Range("D16:D18").Copy
actWb.Activate
Cells(i, 2).PasteSpecial Paste:=xlPasteValues, Transpose:=True