thmh
06-20-2011, 11:40 AM
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
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
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
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