Hi Kristan,

Try:

'=========================
Sub CopySheetFromAll()
Dim srcWB As Workbook, destWB As Workbook
Dim sName As String
Dim MyFiles() As String
Dim i As Long
Dim DestSh As Worksheet
Dim SrcSh As Worksheet
Dim LRow As Long
Dim sPath As String
Dim RngToCopy As Range
Dim sSaveAsName As String

sPath = "C:\MYDIR" '<<==== CHANGE

sSaveAsName = Application.DefaultFilePath _
& "\" & "MySummary " & Format _
(Date, "yyyy-mm-dd") '<<==== CHANGE

If Right(sPath, 1) < "\" Then
sPath = sPath & "\"
End If

sName = Dir(sPath & "*.xls")
If sName = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo Cleanup

Application.ScreenUpdating = False

Set destWB = Workbooks.Add
Set DestSh = destWB.Worksheets(1)

DestSh.Name = "Summary"

i = 0
Do While sName < ""
i = i + 1
ReDim Preserve MyFiles(1 To i)
MyFiles(i) = sName
sName = Dir()
Loop

For i = LBound(MyFiles) To UBound(MyFiles)
Set srcWB = Workbooks.Open(sPath & MyFiles(i))

Set SrcSh = srcWB.Sheets("Sheet1") '<<===== CHANGE

With SrcSh.UsedRange
On Error Resume Next
Set RngToCopy = _
.Offset(1).Resize(.Rows.Count - 1)
On Error GoTo Cleanup
If i = 1 Then .Rows(1).Copy DestSh.Cells(1)
End With

LRow = LastRow(DestSh)

If Not RngToCopy Is Nothing Then
RngToCopy.Copy DestSh.Cells(LRow + 1, 1)
End If

srcWB.Close (False)
Set RngToCopy = Nothing
Next
DestSh.Cells(1).Select

Application.DisplayAlerts = True
destWB.SaveAs sSaveAsName
Cleanup:
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With

End Sub
'<<=========================

'=========================
Function LastRow(sh As Worksheet)
'//Function posted by Ron de Bruin
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
'<<=========================


Change the value of sPath to that of the folder holding the files to be
summarised.

If the name of the worksheets to be copied is other than "Sheet1", alter the
Set srcSheet line accordingly.

Change the value of sSaveAsName to a name for the new summary workbook that
suits your purposes.

---
Regards,
Norman



"Kstalker" wrote in
message ...

Back again on this code.

The code works perfectly Norman but i have to change the way it works
slightly.

Instead of copying sheets out of the four files specified I need to
copy a single sheet out of every workbook in one folder. Again copying
the used range and offsetting in all but the first sheet copied.

Have tried to use some code posted but no success

All help appreciated


--
Kstalker
------------------------------------------------------------------------
Kstalker's Profile:
http://www.excelforum.com/member.php...o&userid=24699
View this thread: http://www.excelforum.com/showthread...hreadid=382670