Hi Philip

There is no check in this code example to see if the file is open.
Every file in the folder must be closed



--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm


"Philip" wrote in message ...
Love this newsgroup! I've been away for a few years, came lokking for help, and didn't even need to ask my question!
Ron de Bruin has the VBA below in his http://www.rondebruin.nl/copy3.htm#Range page, which does what I want to do. Problem is,
when the macro gets to <Set mybook = Workbooks.Open(FNames), a message tells me my working workbook ("Class Summary") is already
open. If I click "yes", nothing further happens. If "No", I am taken to VBA Editor highlighting the aforementioned line. If I then
stop the debugging, the process continues to a satifactory conclusion.
As this workbook will be used by less skilled users, I need to resolve this. What am I doing wrong?

I've changed <MyPath as advised, and have a sheet named "Sheet1" in the workbook. The workbooks from which I want to take the
range A4:I30 from sheet1 in each case, are all in the same folder, but may or may not be open: does this matter? It doesn't seem
to once I stop the debugger.

Ron's code is below with the changes I've made.

Philip


Sub Example1()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "D:\Philip's Documents\aPhilip\Keith"
ChDrive MyPath
ChDir MyPath


FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
basebook.Worksheets(1).Cells.Clear
'clear all cells on the first sheet
rnum = 1

Do While FNames < ""
Set mybook = Workbooks.Open(FNames)
Set sourceRange = mybook.Worksheets(1).Range("A4:n30")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, "A")

'basebook.Worksheets(1).Cells(rnum, "O").Value = mybook.Name
' This will add the workbook name in column D if you want

sourceRange.Copy destrange
' Instead of this line you can use the code below to copy only the values

' With sourceRange
' Set destrange = basebook.Worksheets(1).Cells(rnum,"A"). _
' Resize(.Rows.Count, .Columns.Count)
' End With
' destrange.Value = sourceRange.Value

mybook.Close False
rnum = rnum + SourceRcount
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub