Hi simplyxl
I misunderstood...I thought the compiler Code was creating a new Workbook.
Replace ALL Code in Module CreateNewBook with this Code...let me know of issues.
Option Explicit
Sub Create_Book()
Dim myPath As String
Dim wb1 As Workbook
Dim vWks As Variant
Dim NewBook As Workbook
Dim NewBookName As String
Dim FileFormatNum As Long
Dim iReply As Integer
Dim i As Long
Dim LR As Long
Dim vWksLR As Long
Dim LC As Long
Dim yourArray As Variant
Dim Rng As Range
Dim cel As Range
Dim ws As Worksheet
Set Rng = Nothing
Set wb1 = Nothing
Set NewBook = Nothing
Set ws = Sheets("Split and Save")
ws.Range("A1").ClearContents
ws.Range("A1").NumberFormat = "[$-409]mmmm d, yyyy;@"
frmCalendar.Show_Cal
If ws.Range("A1").Value = "" Then
MsgBox "Please Select Report Date"
Exit Sub
End If
NewBookName = "Daily Sales Stats - Financial Year - 2013-2014 - " & ws.Range("A1").Text
Application.ScreenUpdating = False
myPath = ThisWorkbook.Path & "\"
If Not FileFolderExists(myPath & NewBookName & ".xlsx") Then
Application.SheetsInNewWorkbook = 4
Set NewBook = Workbooks.Add
With NewBook
FileFormatNum = 51
Application.DisplayAlerts = False
.SaveAs Filename:=myPath & NewBookName, FileFormat:=FileFormatNum
Application.DisplayAlerts = True
End With
Else
iReply = MsgBox(Prompt:=NewBookName _
& Format(Date, "mmmm d, yyyy") & " already exists," & vbCrLf _
& " Do you wish to Delete the file and Create a new file?", Buttons:=vbYesNoCancel, Title:="WORKBOOK EXISTS")
If iReply = vbYes Then
On Error Resume Next
Kill myPath & NewBookName & ".xlsx"
On Error GoTo 0
Set NewBook = Nothing
Application.SheetsInNewWorkbook = 4
Set NewBook = Workbooks.Add
With NewBook
Application.DisplayAlerts = False
FileFormatNum = 51
.SaveAs Filename:=myPath & NewBookName, FileFormat:=FileFormatNum
Application.DisplayAlerts = True
End With
Else
wb1.Close , False
Exit Sub
End If
End If
i = 1
With ThisWorkbook
For Each vWks In Array("East", "West", "North", "South")
.Sheets(vWks).UsedRange.Copy
vWksLR = .Sheets(vWks).Cells.Find("*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
With Workbooks(NewBookName & ".xlsx").Sheets("Sheet" & i)
.Range("A1").PasteSpecial xlPasteFormats
.Range("A1").PasteSpecial xlPasteValues
.Range("A1").Value = "Date"
.Range("B1").Value = "Sales Report:"
If vWksLR > 1 Then
LR = .Range("A" & .Rows.Count).End(xlUp).Row
LC = .Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set Rng = .Range(.Cells(2, 1), .Cells(LR, 1))
'Get and Split out the Sales Report Name
For Each cel In Rng
yourArray = Split(cel.Value, "-")
cel.Offset(0, 1).Value = yourArray(UBound(yourArray))
cel.Offset(0, 1).Value = Split(cel.Offset(0, 1).Value, ".")(0)
Next cel
.Range("A2").Value = ws.Range("A1").Value
.Range("A2").Copy .Range("A3:A" & LR)
.Columns("A:B").HorizontalAlignment = xlLeft
Set Rng = Nothing
Set Rng = .Range(.Cells(1, 1), .Cells(1, LC))
With Rng
.HorizontalAlignment = xlCenter
.Font.Name = "Calibri"
.Font.FontStyle = "Bold"
.Font.Size = 11
.Interior.Pattern = xlSolid
.Interior.ThemeColor = xlThemeColorDark2
End With
With .UsedRange.Offset(1, 0).Font
.Name = "Calibri"
.FontStyle = "Regular"
.Size = 11
End With
End If
.Name = vWks
.Cells.Columns.AutoFit
Application.CutCopyMode = False
End With
i = i + 1
Next vWks
End With
Set Rng = Nothing
Set wb1 = Nothing
Set NewBook = Nothing
Application.ScreenUpdating = True
End Sub
Public Function FileFolderExists(strFullPath As String) As Boolean
'Author : Ken Puls (www.excelguru.ca)
'Macro Purpose: Check if a file or folder exists
On Error GoTo EarlyExit
If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
EarlyExit:
On Error GoTo 0
End Function
LinkBack URL
About LinkBacks
simplyxl 
Register To Reply
Bookmarks