I need to extract data from a directory called: C:\2010 Performance Review
here's the parameters...
1. There are an unknown number of files in the directory.
2. The files have unknown names.
3. The files - have the same structure as far as sheet names etc... (it's just the names that are different and unknown)
4. The data must be extracted without opening the files (each file is about 7 mb so too slow to open each one....)- there is total of 5 different pieces of information I need from each file.
5. It has to work with both excel 2003 and 2007 - so I can't use Application.FileSearch
6. The data when extracted will look like:
File name1 Data1 Data2 Data 3 Data 4 Data5
File name2 Data1 Data2 Data 3 Data 4 Data5
File name3 Data1 Data2 Data 3 Data 4 Data5
File name4 Data1 Data2 Data 3 Data 4 Data5
etc...
7. A nice to have.... would be to then email the data collected in #6 to someone.
I had created this a few years ago...with help from this forum... and it worked with excel 2003 (it didn't have the email idea that's in #7)
I now need to get it to work with 2003 and 2007.
The problem is that my programming skills have gone way down....
Thank so much for everyone's help in advance.
Here's the old code...
Private Sub Worksheet_Activate()
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Dim sdir, fdir As String
On Error Resume Next
Application.ScreenUpdating = False
Set fs = Application.FileSearch
With fs
sdir = "C:\2010 Performance Review"
.LookIn = sdir
.Filename = ".xls"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
'Range("a" & i).Hyperlinks.Add Anchor:=Range("a" & i), _
Address:=.FoundFiles(i)
fdir = .FoundFiles(i)
Range("a" & i + 2).Formula = Right(fdir, Len(fdir) - Len(sdir) - 1)
Range("b" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c146"
Range("c" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c147"
Range("d" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c148"
Range("e" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c149"
Range("f" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c145"
Next i
End If
End With
Application.ScreenUpdating = True
Columns("A:A").Select
Selection.Columns.AutoFit
Selection.Font.ColorIndex = 0
Columns("C:C").Select
Selection.NumberFormat = "0.00"
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
here's the parameters...
1. There are an unknown number of files in the directory.
2. The files have unknown names.
3. The files - have the same structure as far as sheet names etc... (it's just the names that are different and unknown)
4. The data must be extracted without opening the files (each file is about 7 mb so too slow to open each one....)- there is total of 5 different pieces of information I need from each file.
5. It has to work with both excel 2003 and 2007 - so I can't use Application.FileSearch
6. The data when extracted will look like:
File name1 Data1 Data2 Data 3 Data 4 Data5
File name2 Data1 Data2 Data 3 Data 4 Data5
File name3 Data1 Data2 Data 3 Data 4 Data5
File name4 Data1 Data2 Data 3 Data 4 Data5
etc...
7. A nice to have.... would be to then email the data collected in #6 to someone.
I had created this a few years ago...with help from this forum... and it worked with excel 2003 (it didn't have the email idea that's in #7)
I now need to get it to work with 2003 and 2007.
The problem is that my programming skills have gone way down....
Thank so much for everyone's help in advance.
Here's the old code...
Private Sub Worksheet_Activate()
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.ClearContents
Dim sdir, fdir As String
On Error Resume Next
Application.ScreenUpdating = False
Set fs = Application.FileSearch
With fs
sdir = "C:\2010 Performance Review"
.LookIn = sdir
.Filename = ".xls"
If .Execute > 0 Then
For i = 1 To .FoundFiles.Count
'Range("a" & i).Hyperlinks.Add Anchor:=Range("a" & i), _
Address:=.FoundFiles(i)
fdir = .FoundFiles(i)
Range("a" & i + 2).Formula = Right(fdir, Len(fdir) - Len(sdir) - 1)
Range("b" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c146"
Range("c" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c147"
Range("d" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c148"
Range("e" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c149"
Range("f" & i + 2).Formula = "='" & sdir & "\[" & Right(fdir, Len(fdir) - Len(sdir) - 1) & "]Answer Questions'!c145"
Next i
End If
End With
Application.ScreenUpdating = True
Columns("A:A").Select
Selection.Columns.AutoFit
Selection.Font.ColorIndex = 0
Columns("C:C").Select
Selection.NumberFormat = "0.00"
Range("A3").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
