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

This will get a list of all .xls files in that folder and all subfolders. You
can process them after you have the list:

Option Explicit
Dim myFileNames() As String
Dim fCtr As Long
Sub testme()

Dim FinalFolderName As String
Dim CurrentFolderName As String

Dim FSO As Object
Dim CurrentFolder As Object
Dim myFolder As Object
Dim myFile As Object

' Dim FSO As Scripting.FileSystemObject
' Dim CurrentFolder As Scripting.Folder
' Dim myFolder As Scripting.Folder
' Dim myFile As Scripting.File

CurrentFolderName = "C:\my documents\excel"

Set FSO = CreateObject("Scripting.FileSystemObject")
' Set FSO = New Scripting.FileSystemObject

If FSO.FolderExists(CurrentFolderName) = False Then
MsgBox "Not a good starting folder"
Exit Sub
End If

Set CurrentFolder = FSO.GetFolder(CurrentFolderName)

fCtr = 0
For Each myFile In CurrentFolder.Files
If LCase(Right(myFile.Name, 4)) = ".xls" Then
fCtr = fCtr + 1
ReDim Preserve myFileNames(1 To fCtr)
myFileNames(fCtr) = myFile.Path
End If
Next myFile

If fCtr = 0 Then
MsgBox "no files found"
Exit Sub
End If

'process your files here
For fCtr = LBound(myFileNames) To UBound(myFileNames)
MsgBox myFileNames(fCtr)
Next fCtr

End Sub



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

--

Dave Peterson

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

hi,

it does not help. it gives the message MsgBox "no files found"

--
SAHRAYICEDIT-ISTANBUL


"Dave Peterson":

This will get a list of all .xls files in that folder and all subfolders. You
can process them after you have the list:

Option Explicit
Dim myFileNames() As String
Dim fCtr As Long
Sub testme()

Dim FinalFolderName As String
Dim CurrentFolderName As String

Dim FSO As Object
Dim CurrentFolder As Object
Dim myFolder As Object
Dim myFile As Object

' Dim FSO As Scripting.FileSystemObject
' Dim CurrentFolder As Scripting.Folder
' Dim myFolder As Scripting.Folder
' Dim myFile As Scripting.File

CurrentFolderName = "C:\my documents\excel"

Set FSO = CreateObject("Scripting.FileSystemObject")
' Set FSO = New Scripting.FileSystemObject

If FSO.FolderExists(CurrentFolderName) = False Then
MsgBox "Not a good starting folder"
Exit Sub
End If

Set CurrentFolder = FSO.GetFolder(CurrentFolderName)

fCtr = 0
For Each myFile In CurrentFolder.Files
If LCase(Right(myFile.Name, 4)) = ".xls" Then
fCtr = fCtr + 1
ReDim Preserve myFileNames(1 To fCtr)
myFileNames(fCtr) = myFile.Path
End If
Next myFile

If fCtr = 0 Then
MsgBox "no files found"
Exit Sub
End If

'process your files here
For fCtr = LBound(myFileNames) To UBound(myFileNames)
MsgBox myFileNames(fCtr)
Next fCtr

End Sub



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

--

Dave Peterson

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

Maybe you specified the wrong folder.

excel-tr wrote:

hi,

it does not help. it gives the message MsgBox "no files found"

--
SAHRAYICEDIT-ISTANBUL

"Dave Peterson":

This will get a list of all .xls files in that folder and all subfolders. You
can process them after you have the list:

Option Explicit
Dim myFileNames() As String
Dim fCtr As Long
Sub testme()

Dim FinalFolderName As String
Dim CurrentFolderName As String

Dim FSO As Object
Dim CurrentFolder As Object
Dim myFolder As Object
Dim myFile As Object

' Dim FSO As Scripting.FileSystemObject
' Dim CurrentFolder As Scripting.Folder
' Dim myFolder As Scripting.Folder
' Dim myFile As Scripting.File

CurrentFolderName = "C:\my documents\excel"

Set FSO = CreateObject("Scripting.FileSystemObject")
' Set FSO = New Scripting.FileSystemObject

If FSO.FolderExists(CurrentFolderName) = False Then
MsgBox "Not a good starting folder"
Exit Sub
End If

Set CurrentFolder = FSO.GetFolder(CurrentFolderName)

fCtr = 0
For Each myFile In CurrentFolder.Files
If LCase(Right(myFile.Name, 4)) = ".xls" Then
fCtr = fCtr + 1
ReDim Preserve myFileNames(1 To fCtr)
myFileNames(fCtr) = myFile.Path
End If
Next myFile

If fCtr = 0 Then
MsgBox "no files found"
Exit Sub
End If

'process your files here
For fCtr = LBound(myFileNames) To UBound(myFileNames)
MsgBox myFileNames(fCtr)
Next fCtr

End Sub



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

--

Dave Peterson


--

Dave Peterson

You can then use it like this:

Example11 ("D:\folder") or

Example11 ("D:\folder")

Hope that helped


--
urkec


"excel-tr" wrote:

hi,

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