jdub12280
09-28-2010, 07:17 AM
Hello VBAX experts,
I have searched and tinkered with a few samples found here and there, but none seem to be working as I intend. I have a wb where I export certain worksheets over to an archive by moving a sheet to a new wb, renaming the wb, and saving in a predetermined directory. I would like to be able to insert the following code into the "ThisWorkbook" module of the NEWLY created wb before it is saved and closed.
Here is the code i use to export to the archive:
Sub MoveToArchive()
'
' MoveToArchive Macro
' Macro recorded 7/16/2010 by SanAntonio - JS1982
'
'
'Declare variables
Dim MoveWks As Worksheet
Set MoveWks = ThisWorkbook.Sheets("Sep 25") '<--this line changes daily
Dim CopyRng As Range
Set CopyRng = MoveWks.Range("A1:EZ1313")
Dim Fn As String 'new wkb File Name
Fn = "STR_09_25_10.xlsb" '<--this line changes daily
Dim Fp As String 'new wkb File Path
Fp = "\\Omitted\for\this\SalesTrackerArchive\ (file://\\Omitted\for\this\SalesTrackerArchive\)"
Dim NewWkb As Workbook 'new wkb object set after wks.move
'Dim modSource As vbcomponent
'Dim modTarget As vbcomponent
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'kill all formula's and links by copy / paste special
'move file to new book
With MoveWks
.Select
Application.Run ("UnProtectSheet")
End With
With CopyRng
.Copy
.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
With MoveWks
.Range("E5").Select
Application.Run ("ProtectActiveSheet")
.Move
End With
Set NewWkb = ActiveWorkbook
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
''On Error Resume Next
''loop to copy Workbook.open module to new workbook (allows outlining on pw protected sheets)
'For Each modSource In ThisWorkbook.VBProject.VBComponents
''if it is a module (vbcomponent type = 1 means it is a module)
'If modSource.Type = 1 Then
''Create a new module in new workbook
'Set modTarget = NewWkb.VBProject.VBComponents.Add(vbext_ct_StdModule)
''Rename it to original module name in source workbook
'modTarget.Name = modSource.Name
''Put all code in source module throught new module in new workbok
'modTarget.CodeModule.InsertLines 1, modSource.CodeModule.Lines(1, modSource.CodeModule.CountOfLines)
'End If
'Next
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
ChDir Fp
'save new workbook in archive
NewWkb.SaveAs FileName:=Fp & Fn _
, FileFormat:=50, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'close new workbook after save
NewWkb.Close
'restore application settings
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Here is the code that i need copied into the ThisWorkbook mod of the new wb before I close and save it.
Private Sub Workbook_Open()
Application.Calculation = xlCalculationAutomatic '<--MAKE SURE CALC IS ON
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ("LINKS") And ws.Visible = xlSheetVisible Then
With ws
.Protect Password:="JS1982", userinterfaceonly:=True
.EnableOutlining = True
.EnableAutoFilter = True
'.Cells.EntireColumn.AutoFit
.Outline.ShowLevels rowlevels:=2
.Outline.ShowLevels rowlevels:=0, columnlevels:=2
End With
End If
On Error Resume Next
Next ws
Application.ScreenUpdating = True
End Sub
Any thoughts, suggestions, corrections are greatly appreciated...
Thanks again,
Justin
I have searched and tinkered with a few samples found here and there, but none seem to be working as I intend. I have a wb where I export certain worksheets over to an archive by moving a sheet to a new wb, renaming the wb, and saving in a predetermined directory. I would like to be able to insert the following code into the "ThisWorkbook" module of the NEWLY created wb before it is saved and closed.
Here is the code i use to export to the archive:
Sub MoveToArchive()
'
' MoveToArchive Macro
' Macro recorded 7/16/2010 by SanAntonio - JS1982
'
'
'Declare variables
Dim MoveWks As Worksheet
Set MoveWks = ThisWorkbook.Sheets("Sep 25") '<--this line changes daily
Dim CopyRng As Range
Set CopyRng = MoveWks.Range("A1:EZ1313")
Dim Fn As String 'new wkb File Name
Fn = "STR_09_25_10.xlsb" '<--this line changes daily
Dim Fp As String 'new wkb File Path
Fp = "\\Omitted\for\this\SalesTrackerArchive\ (file://\\Omitted\for\this\SalesTrackerArchive\)"
Dim NewWkb As Workbook 'new wkb object set after wks.move
'Dim modSource As vbcomponent
'Dim modTarget As vbcomponent
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'kill all formula's and links by copy / paste special
'move file to new book
With MoveWks
.Select
Application.Run ("UnProtectSheet")
End With
With CopyRng
.Copy
.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks _
:=False, Transpose:=False
Application.CutCopyMode = False
End With
With MoveWks
.Range("E5").Select
Application.Run ("ProtectActiveSheet")
.Move
End With
Set NewWkb = ActiveWorkbook
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
''On Error Resume Next
''loop to copy Workbook.open module to new workbook (allows outlining on pw protected sheets)
'For Each modSource In ThisWorkbook.VBProject.VBComponents
''if it is a module (vbcomponent type = 1 means it is a module)
'If modSource.Type = 1 Then
''Create a new module in new workbook
'Set modTarget = NewWkb.VBProject.VBComponents.Add(vbext_ct_StdModule)
''Rename it to original module name in source workbook
'modTarget.Name = modSource.Name
''Put all code in source module throught new module in new workbok
'modTarget.CodeModule.InsertLines 1, modSource.CodeModule.Lines(1, modSource.CodeModule.CountOfLines)
'End If
'Next
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
'"""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""""
ChDir Fp
'save new workbook in archive
NewWkb.SaveAs FileName:=Fp & Fn _
, FileFormat:=50, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'close new workbook after save
NewWkb.Close
'restore application settings
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Here is the code that i need copied into the ThisWorkbook mod of the new wb before I close and save it.
Private Sub Workbook_Open()
Application.Calculation = xlCalculationAutomatic '<--MAKE SURE CALC IS ON
Dim wb As Workbook
Dim ws As Worksheet
Application.ScreenUpdating = False
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> ("LINKS") And ws.Visible = xlSheetVisible Then
With ws
.Protect Password:="JS1982", userinterfaceonly:=True
.EnableOutlining = True
.EnableAutoFilter = True
'.Cells.EntireColumn.AutoFit
.Outline.ShowLevels rowlevels:=2
.Outline.ShowLevels rowlevels:=0, columnlevels:=2
End With
End If
On Error Resume Next
Next ws
Application.ScreenUpdating = True
End Sub
Any thoughts, suggestions, corrections are greatly appreciated...
Thanks again,
Justin