copy workbooks to different folder

[thmh]

hy
i need to copy workbooks from folder and all sub-folders "D:\Data" , to "D:\Copy" , copied workbooks need's to have only values ,

i did test with code below , macro opens workbooks in folder (not sub folder) and copy/past sheets , problem is excel crashes after basebook gets larger then 12mb

can it be modified to something like :

Set basebook = new workbook
...
basebook.Save as , name=mybook name , file type=xlsx , folder="D:\Copy"( if from sub folder "D:\Data\1" then folder="D:\Copy\1")

or there is better solution , i use excel 07


[vba]

Sub atest_copy_sheets()


Dim basebook As Workbook
Dim mybook As Workbook
Dim n As Long
Dim ws As Worksheet

Dim Coll_Docs As New Collection
Dim Search_path, Search_Filter, Search_Fullname As String
Dim DocName As String

Dim i As Long



With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False

Search_path = "D:\Data\" ' where ?
Search_Filter = "*.xlsm" ' what ?
Set Coll_Docs = Nothing



DocName = Dir(Search_path & Search_Filter) '& "\"


Do Until DocName = "" ' build the collection
Coll_Docs.Add Item:=DocName
DocName = Dir
Loop



MsgBox "There were " & Coll_Docs.Count & " file(s) found."

For i = Coll_Docs.Count To 1 Step -1
Search_Fullname = Search_path & Coll_Docs(i) '& "\"


' (your code here)


If Coll_Docs.Count > 0 Then
Set basebook = ThisWorkbook
For n = i To 1 Step -Coll_Docs.Count
Set mybook = Workbooks.Open(Search_path & Coll_Docs(n))
With mybook
For Each ws In Sheets
ws.Copy after:=basebook.Sheets(basebook.Sheets.Count)
With ActiveSheet '.UsedRange
If ws.Name Like " #" Or ws.Name Like " ##" Or ws.Name Like " #MW" Or ws.Name Like " ##MW" Then

Else
.Unprotect
.UsedRange.Value = .UsedRange.Value
' .UsedRange.ClearFormats
End If
End With
Next
End With

mybook.Close SaveChanges:=False
' Set mybook = Nothing
Next n
.CutCopyMode = False
basebook.Save
End If



Next



.DisplayAlerts = True
.ScreenUpdating = True
.CutCopyMode = False
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With


End Sub

[/vba]

[thmh]

her is code for copy/past sheets to new workbooks

[vba]
Sub atest_copy_sheets()


Dim basebook As Workbook
Dim mybook As Workbook
Dim n As Long
Dim ws As Worksheet

Dim Coll_Docs As New Collection
Dim Search_path, Search_Filter, Search_Fullname As String
Dim DocName As String

Dim i As Long



With Application
.EnableEvents = False
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False

Search_path = "D:\Data\" ' where ?
Search_Filter = "*.xlsm" ' what ?
Set Coll_Docs = Nothing



DocName = Dir(Search_path & Search_Filter) '& "\"


Do Until DocName = "" ' build the collection
Coll_Docs.Add Item:=DocName
DocName = Dir
Loop



MsgBox "There were " & Coll_Docs.Count & " file(s) found."

For i = Coll_Docs.Count To 1 Step -1
Search_Fullname = Search_path & Coll_Docs(i) '& "\"


' (your code here)


If Coll_Docs.Count > 0 Then
Set basebook = Workbooks.Add 'ThisWorkbook
For n = i To 1 Step -Coll_Docs.Count
Set mybook = Workbooks.Open(Search_path & Coll_Docs(n))
With mybook
For Each ws In Sheets
ws.Copy after:=basebook.Sheets(basebook.Sheets.Count)
With ActiveSheet '.UsedRange
If ws.Name Like " #" Or ws.Name Like " ##" Or ws.Name Like " #MW" Or ws.Name Like " ##MW" Then

Else
.Unprotect
.UsedRange.Value = .UsedRange.Value
'.UsedRange.ClearFormats
End If
End With
Next

With basebook
.Sheets(Array("Sheet1", "Sheet2", "Sheet3")).Delete
.SaveAs Filename:="D:\Copy\" & mybook.Name & ".xlsx" 'Save
.Close 'SaveChanges:=True
End With

.Close SaveChanges:=False 'mybook
'Set mybook = Nothing
End With
Next n
.CutCopyMode = False
' basebook.Save
End If



Next



.DisplayAlerts = True
.ScreenUpdating = True
.CutCopyMode = False
.Calculation = xlCalculationAutomatic
.EnableEvents = True
End With


End Sub
[/vba]