Create a worksheet with pointers to all the different workbooks/worksheets/cells and their respective destination. If it is something that will change over time, put date stamps on the rows, something like this:
Source path Source worksheet Source cell Dest worksheet Dest cell Date Start Date End
c:\temp\test.xls Sheet1 A1 Sheet1 B17 01-01-12 12-15-12
c:\temp\test.xls Sheet1 B1 Sheet1 B21 01-01-12 12-15-12
c:\temp\test.xls Sheet1 C1 Sheet1 B25 01-01-12 12-15-12
c:\temp\test.xls Sheet1 D1 Sheet1 B29 01-01-12 12-15-12
c:\temp\test.xls Sheet1 E1 Sheet1 B33 01-01-12 12-15-12
Name the top left cell of your pointers something like CellMap. Then, some code like this will do it:
Option Explicit
Public Sub ImportSheets()
Dim rngMap As Excel.Range
Dim wkbTemp As Excel.Workbook
Dim scpWkb As Object
Dim arrMapIn As Variant
Dim arrMap As Variant
Dim arrPath As Variant
Dim intCol As Integer
Dim lngLastRow As Long
Dim lngRow As Long
Dim lngMap As Long
Dim datCurr As Date
Set rngMap = ThisWorkbook.Names("CellMap").RefersToRange
intCol = rngMap.Column
On Error Resume Next
lngLastRow = rngMap.Parent.Columns(intCol).Find(What:="*", After:=rngMap.Parent.Cells(1, intCol), _
LookAt:=xlPart, LookIn:=xlValues, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Row
If Err <> 0 Then
lngLastRow = 0
End If
On Error GoTo 0
If lngLastRow > 1 Then
arrMapIn = rngMap.Offset(1, 0).Resize(lngLastRow - rngMap.Row, 7).Value
ReDim arrMap(1 To 6, 1 To 1)
datCurr = Date
Set scpWkb = CreateObject("Scripting.Dictionary")
scpWkb.CompareMode = vbTextCompare
For lngRow = LBound(arrMapIn, 1) To UBound(arrMapIn, 1)
' Build the date-bounded map array
If arrMapIn(lngRow, 6) <= datCurr _
And arrMapIn(lngRow, 7) >= datCurr Then
If arrMap(1, UBound(arrMap, 2)) > "" Then
ReDim Preserve arrMap(1 To 6, 1 To UBound(arrMap, 2) + 1)
End If
lngMap = UBound(arrMap, 2)
For intCol = 1 To 5
arrMap(intCol, lngMap) = arrMapIn(lngRow, intCol)
Next intCol
arrPath = Split(arrMapIn(lngRow, 1), "\")
arrMap(6, lngMap) = arrPath(UBound(arrPath))
' Make sure the workbook is open
If Not scpWkb.Exists(arrMapIn(lngRow, 1)) Then
scpWkb.Item(arrMapIn(lngRow, 1)) = lngRow
On Error Resume Next
Set wkbTemp = Application.Workbooks(arrPath(UBound(arrPath)))
If wkbTemp Is Nothing Then
Set wkbTemp = Application.Workbooks.Open(arrMapIn(lngRow, 1), _
UpdateLinks:=False, ReadOnly:=True)
End If
On Error GoTo 0
If wkbTemp Is Nothing Then
MsgBox "Unable to open " & arrMapIn(lngRow, 1) & vbCrLf _
& "Aborting import", vbOKOnly
Exit Sub
Else
Set wkbTemp = Nothing
End If
End If
End If
Next lngRow
For lngRow = LBound(arrMap, 2) To UBound(arrMap, 2)
ThisWorkbook.Worksheets(arrMap(4, lngRow)).Range(arrMap(5, lngRow)).Value = _
Application.Workbooks(arrMap(6, lngRow)).Worksheets(arrMap(2, lngRow)).Range(arrMap(3, lngRow)).Value
Next lngRow
End If
End Sub