Sub Sub JobPack_Creation()
Dim JType As String
Dim FPath As String
Dim Order_No As String
Dim WorkbookName As String
Dim NewDir As String
CurrentPath = ActiveWorkbook.Path
WorkbookName = ActiveWorkbook.Name
Call A3PageTest
'Get file name and path details (estimate number and duct or cable)
With ActiveWorkbook.Worksheets("Entry")
Order_No = Range("G19").Value
If Len(Order_No) < 4 Then
Response = MsgBox("An 8 figure Order No is required ?" & Chr(13) & Chr(10) & _
"Please enter an Order No and try again", vbCritical, _
" Order No required")
Exit Sub
Else
End If
Range("G4").Select
Application.ScreenUpdating = True
End With
NewDir = CurrentPath & "\" & FPath & Range("G19").Value
Call Check_Create_Dir(NewDir, Exchange & "_" & Order_No & "_" & Survey_no)
Application.ScreenUpdating = False
Call SaveEachTabs_as_a_SeperateWorksheet(NewDir, Order_No)
Sheets("Entry").Select
With ActiveSheet.PageSetup
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
End With
Application.ScreenUpdating = True
MsgBox "'Job Pack' files created successfully.", vbInformation + vbOKOnly, "All done."
Application.ScreenUpdating = True
End Sub
Sub Check_Create_Dir(NewDir As String, NewFolder As String)
' If a Folder with the same name exists, create a No. 2
If Not PathExists(NewDir) Then
If Dir(NewDir, vbDirectory) <> NewFolder Then
MkDir (NewDir)
End If
Else
If Dir(NewDir, vbDirectory) <> NewFolder Then
NewDir = NewDir & " - 2"
On Error GoTo NotAllowed:
MkDir (NewDir)
On Error GoTo 0
End If
End If
Exit Sub
NotAllowed:
msg = "2 Folders with the same Order Number " & vbCrLf & _
vbCrLf & " already exist in this location ?"
result = MsgBox(msg, vbCritical, " 2 Folders Exist")
If result = vbOK Then
End
End If
End Sub
#If VBA6 Then
#Else
Function Replace(ByVal sExpression As String, _
ByVal sFind As String, ByVal sReplace As String)
Replace = Application.WorksheetFunction.Substitute(sExpression, sFind, sReplace)
End Function
#End If
Public Sub SaveEachTabs_as_a_SeperateWorksheet(SavePath As String, SaveName As String)
' Get Savepath & SaveName details
Dim MasterWorkbook As String
Dim WorksheetName As String
MasterWorkbook = ActiveWorkbook.Name
For Each ws In Worksheets ' Loop through every worksheet in the workbook
' Create the seperate files
Select Case (ws.Name)
Case "Entry"
Case "Data"
Case Else
'Pass the work sheet name, file path, and file name to the "SaveWorksheet_as_Workbook" procedure
Call SaveWorksheet_as_Workbook(ws.Name, SavePath, SaveName)
End Select
Next ws
End Sub
Public Sub SaveWorksheet_as_Workbook(SheetName As String, SavePath As String, SaveName As String)
' Create seperate file for each w/s present - "SetPrint" instructs how to format Page Setup
Dim NewWorkbookName As String
Dim MasterWorkbook As String
Dim P1Name As String
WorkbookName = ActiveWorkbook.Name
MasterWorkbook = WorkbookName
Application.ScreenUpdating = False
P1Name = SaveName & "_" & SheetName ' SheetName passed from calling procedure
Workbooks.Add xlWorksheet
Sheets("Sheet1").Name = P1Name
ActiveWindow.DisplayGridlines = False
Call SetPrint
ActiveWorkbook.SaveAs FileName:=SavePath & "\" & P1Name
SaveAs2003_Workbook (PathAndName)
Application.ScreenUpdating = False
Workbooks.Open FileName:=SavePath & "\" & P1Name & ".xls", UpdateLinks:=0
Windows(WorkbookName).Activate
Sheets(SheetName).Select
Cells.Select
Selection.Copy
Windows(P1Name & ".xls").Activate
Cells.Select
ActiveSheet.Paste
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveWindow.Zoom = 50
Range("A1").Select
ActiveWorkbook.Save
ActiveWorkbook.BreakLink Name:=SavePath & "\" & P1Name & ".xls", Type:= _
xlExcelLinks
ActiveWorkbook.Close
Range("C3").Select
End Sub
Sub SetPrint()
ActiveSheet.PageSetup.PrintArea = "$C$3:$AH$77"
With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.2)
.RightMargin = Application.InchesToPoints(0.2)
.TopMargin = Application.InchesToPoints(0.2)
.BottomMargin = Application.InchesToPoints(0.2)
.PrintGridlines = False
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.PaperSize = xlPaperA4
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.DisplayHeadings = False
End Sub
Private Function PathExists(pname) As Boolean
Dim x As String
On Error Resume Next
x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True _
Else PathExists = False
End Function
Sub SaveAs2003_Workbook(PathAndName)
'Adapted from code by Ron Debruin
'All saves are sent here.
'Avoid CheckCompatibility dialog when you copy a WorkSheet
'from a 2007-2010 file with things that are new in 2007-2010
'to a new workbook and save this workbook as a 97-2003 workbook
Dim SaveFormat As Long
'Remember the users setting
SaveFormat = Application.DefaultSaveFormat
'Set it to the 97-2003 file format
Application.DefaultSaveFormat = -4143
On Error Resume Next 'added by NJI as Ex2003 doesn't know the 'CheckCompatibility' command
ActiveWorkbook.CheckCompatibility = False
Application.DisplayAlerts = False
PathAndName = Replace(PathAndName, Chr(10), "")
PathAndName = Replace(PathAndName, Chr(13), "")
PathAndName = Replace(PathAndName, "\\", "\", 1)
PathAndName = Replace(PathAndName, ".xls", "", 1) 'Remove ".xls"
'MsgBox PathAndName
ActiveWorkbook.SaveAs PathAndName, FileFormat:=-4143
'Set DefaultSaveFormat back to the users setting
Application.DefaultSaveFormat = SaveFormat
Application.DisplayAlerts = True
MyChanges = False
Exit Sub
Getout:
End Sub
