hi,

I could not understand what to change. adress is to be searched is "D:\folder"
--
SAHRAYICEDIT-ISTANBUL


"urkec":

You can use recursion for that. I changed your sub to call itself, so if you
pass it folder name as argument - Example11 ("C:\someFolder\") - it should
do the work :

Sub Example11(MyPath As String)

Dim basebook As Workbook
Dim mybook As Workbook
Dim SaveDriveDir As String
Dim fso As Object
Dim folder As Object
Dim FNames As Object
Dim FName As Object
Dim xlsCount As Integer

SaveDriveDir = CurDir
xlsCount = 0

Set fso = CreateObject("Scripting.FileSystemObject")
Debug.Print MyPath
Set folder = fso.GetFolder(MyPath)
Set FNames = folder.Files

For Each FName In FNames
If fso.GetExtensionName(FName) = "xls" Then
xlsCount = xlsCount + 1
End If
Next

If xlsCount = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook

For Each FName In FNames

If fso.GetExtensionName(FName) = "xls" Then
Set mybook = Workbooks.Open(FName)
mybook.Worksheets.Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = mybook.Name ' Or use Left(mybook.Name,Len(mybook.Name) - 4)
On Error GoTo 0
' You can use this if you want to copy only the values
' With ActiveSheet.UsedRange
' .Value = .Value
' End With
mybook.Close False
End If

Next

For Each sf In folder.Subfolders
If sf.Name < "System Volume Information" Then
Call Example11(sf.Path)
End If
Next

ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub





--
urkec


"excel-tr" wrote:

hi,

below code ( from ron s site ) is for copying worksheets in different
workbooks in one folder,
how can we revise it to search subfolders as well ?

regards
Sub Example11()
Dim basebook As Workbook
Dim mybook As Workbook
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String


SaveDriveDir = CurDir
MyPath = "D:\folder"


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

Do While FNames < ""
Set mybook = Workbooks.Open(FNames)

mybook.Worksheets.Copy after:= _
basebook.Sheets(basebook.Sheets.Count)
On Error Resume Next
ActiveSheet.Name = mybook.Name ' Or use Left(mybook.Name,
Len(mybook.Name) - 4)
On Error GoTo 0

' You can use this if you want to copy only the values
' With ActiveSheet.UsedRange
' .Value = .Value
' End With

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

--
SAHRAYICEDIT-ISTANBUL