Hi,
I want a macro to copy each worksheet in a Workbook in specific folder Say
"H:\31.03.2011_10.04.2011" with File name as name of the active worksheet &
time of generation. For Example: My Workbook contains 35 sheets named
(Brazil,India,US etc) and i ran the macro at say 04:00 then it should Save
35 worksheets should be saved in specific folder
i.e. "H:\31.03.2011_10.04.2011" named as Brazil 0400 Hrs,India 0400 Hrs &
So on.
I surfed the internet and found the following code but i am not able to
manipulate to suit my requirement(furnished below). Hope the member of this
group could help me out.
-----------------------------------------------------------------------------------------------------------------------------------------------------------
Sub MakeMultipleXLSfromWB()
'Split worksheets in current workbook into
' many separate workbooks D.McRitchie, 2004-06-12
'Close each module AND the VBE before running to save time
' provides a means of seeing how big sheets really are
'Hyperlinks and formulas pointing to other worksheets within
' the original workbook will usually be unuseable in the new workbooks.
Dim CurWkbook As Workbook
Dim wkSheet As Worksheet
Dim newWkbook As Workbook
Dim wkSheetName As String
Dim shtcnt(3) As Long
Dim xpathname As String, dtimestamp As String
dtimestamp = Format(Now, "yyyymmdd_hhmmss")
xpathname = "H:\31.03.2011_10.04.2011" & dtimestamp & "\"
MkDir xpathname
Set CurWkbook = Application.ActiveWorkbook
shtcnt(2) = ActiveWorkbook.Sheets.Count
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each wkSheet In CurWkbook.Worksheets
shtcnt(1) = shtcnt(1) + 1
Application.StatusBar = shtcnt(1) & "/" & shtcnt(2) & _
" " & wkSheet.Name
wkSheetName = Trim(wkSheet.Name)
If wkSheetName = Left(Application.ActiveWorkbook.Name, _
Len(Application.ActiveWorkbook.Name) - 4) Then _
wkSheetName = wkSheetName & "_D" & dtimestamp
Workbooks.Add
ActiveWorkbook.SaveAs _
Filename:=xpathname & wkSheetName & ".xls", _
FileFormat:=xlNormal, Password:="", _
WriteResPassword:="", CreateBackup:=False, _
ReadOnlyRecommended:=False
Set newWkbook = ActiveWorkbook
Application.DisplayAlerts = False
newWkbook.Worksheets("sheet1").Delete
On Error Resume Next
newWkbook.Worksheets(wkSheet.Name).Delete
On Error GoTo 0
Application.DisplayAlerts = True
CurWkbook.Worksheets(wkSheet.Name).Copy Before:=newWkbook.Sheets(1)
'no duplicate sheet1 because they begin with "a"
ActiveWorkbook.Save
ActiveWorkbook.Close
Next wkSheet
Application.StatusBar = False 'return control to Excel
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
-----------------------------------------------------------
Regards,
C.G.Kumar
--
----------------------------------------------------------------------------------
Some important links for excel users:
1. Follow us on TWITTER for tips tricks and links :
http://twitter.com/exceldailytip
2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310
3. Excel tutorials at http://www.excel-macros.blogspot.com
4. Learn VBA Macros at http://www.quickvba.blogspot.com
5. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
<><><><><><><><><><><><><><><><><><><><><><>
Like our page on facebook , Just follow below link
http://www.facebook.com/discussexcel
