Try this code, which gets the values without opening the workbooks as posted
before.
As your copy ranges are small it probably is faster than opening the
workbooks.
Not tested, but it should work.
Sub Macro1()
Dim i As Long
Dim n As Byte
Dim strFolder As String
Dim strFile As String
Dim strSheet As String
Dim arr(1 To 1, 1 To 3)
Dim lRow As Long
Application.ScreenUpdating = False
strFolder = "E:\beredskap\bensin\"
strSheet = "Beställning"
For i = Range("I2").Value To Range("I3").Value
If i < 100 Then
strFile = "MS0600" & i & ".0.xls"
Else
strFile = "MS060" & i & ".0.xls"
End If
If bFileExists(strFolder & strFile) Then
If FileLen(strFolder & strFile) 300000 Then
For n = 1 To 3
arr(1, n) = GetValueFromWB(strFolder, _
strFile, _
strSheet, _
Cells(2, n + 2).Address)
Next
lRow = Cells(65536, 3).End(xlUp).Offset(1, 0).Row
Range(Cells(lRow, 3), Cells(lRow, 5)) = arr
End If
End If
Next i
Application.ScreenUpdating = True
End Sub
Function GetValueFromWB(path, file, sheet, ref)
'Retrieves a value from a closed workbook
'----------------------------------------
Dim strSep As String
Dim arg As String
'Make sure the file exists
'-------------------------
If Right$(path, 1) < "\" Then
path = path & "\"
End If
If bFileExists(path & file) = False Then
GetValueFromWB = "File Not Found"
Exit Function
End If
'Create the argument
'-------------------
arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
Range(ref).Range("A1").Address(, , xlR1C1)
'Execute an XLM macro
'--------------------
GetValueFromWB = ExecuteExcel4Macro(arg)
End Function
Function bFileExists(ByVal sFile As String) As Boolean
Dim lAttr As Long
On Error Resume Next
lAttr = GetAttr(sFile)
bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0)
On Error GoTo 0
End Function
RBS
"Alf" wrote in message
...
I'm trying to extract from a number of files in a folder.
The files are named MS060XXX.0.xls where XXX is a number ranging from
001 to 850.
My error handling works if there is only one file missing in the range
of files I
want to extract from.
If two ore more files are missing the macro stopps with message "file
not found"
Could anybody please give me a hint how to solve this problem.
Sub Macro1()
'
' Macro1 Macro
'
Dim i As Integer
For i = Range("I2").Value To Range("I3").Value Step 1
ChDir "E:\beredskap\bensin"
Application.ScreenUpdating = False
On Error GoTo Err
If i < 100 Then
Workbooks.Open Filename:="MS0600" & i & ".0.xls"
Else
Workbooks.Open Filename:="MS060" & i & ".0.xls"
End If
If FileLen(ActiveWorkbook.FullName) 300000 Then
Sheets("Beställning").Activate
Range("A2:C2").Copy
Windows("select_files.xls").Activate
Range("C" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
Paste:=xlValues
End If
If i < 100 Then
Windows("MS0600" & i & ".0.xls").Activate
ActiveWorkbook.Close
Else
Windows("MS060" & i & ".0.xls").Activate
ActiveWorkbook.Close
End If
Err:
Next i
Application.ScreenUpdating = True
End Sub
--
Alf
------------------------------------------------------------------------
Alf's Profile:
http://www.excelforum.com/member.php...fo&userid=7112
View this thread: http://www.excelforum.com/showthread...hreadid=550766