copying worksheets
 

hi,

below code 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

copying worksheets
 

Check Ron deBruin's site

"excel-tr" wrote:

hi,

below code 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

copying worksheets
 

check Ron deBruin's site:

http://www.rondebruin.nl/folder.htm

"excel-tr" wrote:

hi,

below code 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

copying worksheets
 

hi,

I got it from ron s site :). But I have to revise it.
--
SAHRAYICEDIT-ISTANBUL


"JLGWhiz":

check Ron deBruin's site:

http://www.rondebruin.nl/folder.htm

"excel-tr" wrote:

hi,

below code 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