The following should do it for you. You would need to simply paste it all into a module and then run the macro CopyMultipleFiles(). This is simply a very quickly skinnied down version from a something I did a few days ago with the help of Dave Peterson from the Excel newsgroups, and a great piece of code from John Walkenbach's book 'Power Programming 2002'. The bit of code from John's book allows a 'select directory' window to appear where you can choose the directory you want from a normal FileOpen type window.
It also doesn't matter if the files are in a single directory or not, so from that aspect may be a bit OTT for your need, but better to have it to start with and lose it if you don't need it. It will trawl through all folders and subfolders from whatever point you choose with the GetDirectory option.
The file will create a new summary sheet in whatever workbook you run the macro from, and will list all the data from that cell in all your files, from A3 downwards. In Col B against that same number it will put a hyperlinbk to the file it pulled the data from, so that if anything looks out of wack, it is easy to know where the data came from and to be able to open the file without a lot of searching.
The macro will pull in the data from A8 in every workbook (Change to suit), and at the moment there is an option to change the row number in the macro via an inputbox message that will appear. If you change the reference you need to change or lose the statement that will allow an amendment to the range as it currently defaults to Col A plus whatever row number you enter. You can lose it altogether, or amend it to allow the user to select a cell with the mouse as opposed to hardwiring a reference in there if you wish. You will need to change one thing though, and that is the statement:-
Set myRng = WB.Worksheets("Labour"
.Range
This simply referred to one of the sheets I was pulling data from in my files. Either put in the correct tab name if it is always the same, or perhaps change it to something like:-
Set myRng = WB.Worksheets(1).Range if it is always the first worksheet in the book etc.
There are a bunch of redundant DIMs in here as this is a quick and dirty skinny down of my module, but you can weed out the redundant stuff.
Thanks once again to John W, who was happy for me to post this with his code in it, and many thanks to the CD in his book which saved me having to type it out in the first place!!.
Option Explicit
Dim UserFile As String
'32-bit API declarations
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Function GetDirectory(Optional Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
' Root folder = Desktop
bInfo.pidlRoot = 0&
' Title in the dialog
If IsMissing(Msg) Then
bInfo.lpszTitle = "Select a folder."
Else
bInfo.lpszTitle = Msg
End If
' Type of directory to return
bInfo.ulFlags = &H1
' Display the dialog
x = SHBrowseForFolder(bInfo)
' Parse the result
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub CopyMultipleFiles()
' This is the macro that the button on the 'Initialise' Sheet initiates
Application.ScreenUpdating = False
Dim a As Range
Dim b As Integer
Dim lRow As Long
Dim c As Range
Dim i As Long
Dim r As Integer
Dim hyprng As String
Dim LstRow As Integer
Dim WB As Workbook
Dim CurWks As Worksheet
Dim myaddr1 As String
Dim myAddr2 As String
Dim myAddr3 As String
Dim myRng As Range
Dim myVal2 As Long
Dim myVal3 As Long
Dim Msg As String
Dim UserResp As String
On Error Resume Next
myaddr1 = "A8"
UserResp = InputBox(">>>>>>>>>> " & myaddr1 & " <<<<<<<<<<<" & vbCrLf & vbCrLf & "Is this the correct range " & _
"to pull in for the Summary Hours on the 'LABOUR' sheet in the BOE files. If yes then just hit " & _
"enter, but if not then please enter the NUMBER ONLY of the correct ROW" & vbCrLf & vbCrLf & " For example 20"
If UserResp = "" Then
myaddr1 = myaddr1
Else: myaddr1 = "A" & UserResp
End If
Msg = "Please select a Directory to Summarise."
UserFile = GetDirectory(Msg)
If UserFile = "" Then
MsgBox "Canceled"
ElseIf Not ContinueProcedure Then
Exit Sub
End If
Set CurWks = ActiveWorkbook.Worksheets.Add
lRow = 0
With Application.FileSearch
.SearchSubFolders = True
.NewSearch
.Filename = ".xls"
.LookIn = UserFile
.FileType = msoFileTypeExcelWorkbooks
.Execute
For i = 1 To .FoundFiles.Count
Set WB = Application.Workbooks.Open _
(Filename:=.FoundFiles(i))
Set myRng = WB.Worksheets("Labour"
.Range(myaddr1)
'Bring in the hours
CurWks.Cells(lRow + 3, "A"
_
.Resize(myRng.Rows.Count, myRng.Columns.Count).Value _
= WB.Worksheets("Labour"
.Range(myaddr1).Value
'Bring in the filename
CurWks.Cells(lRow + 3, myRng.Columns.Count + 3) _
.Resize(myRng.Rows.Count).Value = WB.FullName
lRow = lRow + myRng.Rows.Count
WB.Close savechanges:=False
Next
End With
'Create hyperlinks to each of the files
Dim cell As Range, Rng As Range
Set Rng = Range("D2:I" & Cells.Rows.Count).SpecialCells(xlConstants, xlTextValues)
If Rng Is Nothing Then
MsgBox "nothing in range"
Exit Sub
End If
For Each cell In Rng
If Trim(cell.Value) <> "" Then
ActiveSheet.Hyperlinks.Add Anchor:=cell, Address:=cell.Value, _
ScreenTip:=cell.Value, TextToDisplay:=cell.Value
End If
Next cell
Set myRng = Nothing
Set WB = Nothing
Set CurWks = Nothing
Application.ScreenUpdating = True
End Sub
Private Function ContinueProcedure() As Boolean
Dim Config As Integer
Dim Ans As Integer
Config = vbYesNo + vbQuestion + vbDefaultButton2
Ans = MsgBox(UserFile & " <<< Is This The Correct Directory?", Config)
If Ans = vbYes Then
ContinueProcedure = True
Else: ContinueProcedure = False
End If
End Function
Regards
Ken...............
