Dim sh As Worksheet
Dim CopyRange As Range
Dim Path As String
Dim NameText As String
Dim EntDate As String
Dim wSht As Worksheet
'get file path and w/c date from user
Path = InputBox("Please enter the file path where individual spreadsheets will be created e.g. k:\")
EntDate = InputBox("Please enter the week commencing date")
NameText = InputBox("Please enter any text you would like to add to the filename")
'disable screen updates and auto-recalculation temporarily
Application.ScreenUpdating = False
Application.Calculation = xlManual
'copy each sheet to new workbook
For Each sh In ActiveWorkbook.Worksheets
Set CopyRng = sh.Range("A1:Z500")
CopyRng.Copy
Set ex = CreateObject("Excel.Application")
ex.Visible = False
Set book = ex.Workbooks.Add
Set Sheet = ex.Sheets("Sheet1")
With Sheet
.Name = sh.Name
.Select
.Paste
.Range("d:e").EntireColumn.Hidden = True
.Range("g:g").EntireColumn.Hidden = True
.Range("i:i").EntireColumn.Hidden = True
.Range("M:Z").EntireColumn.Hidden = True
.Range("a:C").EntireColumn.AutoFit
'add date
Sheet.Range("A1").Select
Sheet.Range("A1").FormulaR1C1 = "STOCK REPORT TEMPLATE " & EntDate & Chr(10) & "DEPARTMENT " & UCase(sh.Name)
With Selection.Characters(Start:=1, Length:=19).Font
.Name = "Calibri"
.FontStyle = "Bold"
.Size = 16
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleSingle
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
Sheet.Range("1:1").RowHeight = 45.75
End With
'delete unwanted rows
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(1).Row
lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = lastrow To Firstrow Step -1
With .Cells(Lrow, "U")
If Not IsError(.Value) Then
If .Value = "0" Then .EntireRow.Delete Shift:=xlUp
End If
End With
Next Lrow
'apply conditional formatting
Const RangeToFormat As String = "J6:J500"
Const F1 As String = "=$M6<11%"
Const CI1 As Integer = 3 'red
Const F2 As String = "=AND($M6>11%,$M6<21%)"
Const CI2 As Integer = 44 'orange
Const F3 As String = "=$M6>21%"
Const CI3 As Integer = 4 'green
.DisplayPageBreaks = False
lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
Sheet.Range("J6:J" & lastrow).Select
With Sheet.Range("J6:J" & lastrow)
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:=F1
.FormatConditions(1).Interior.ColorIndex = CI1
.FormatConditions.Add Type:=xlExpression, Formula1:=F2
.FormatConditions(2).Interior.ColorIndex = CI2
.FormatConditions.Add Type:=xlExpression, Formula1:=F3
.FormatConditions(3).Interior.ColorIndex = CI3
End With
End With
'create directories and save files
If Dir(Path + Sheet.Name + "\") = "" Then
MkDir (Path + Sheet.Name + "\")
End If
fname = (Path + Sheet.Name + "\UK " + Sheet.Name + " " + NameText + ".xls")
Set Sheet = ex.Sheets("sheet2")
Sheet.Delete
Set Sheet = ex.Sheets("sheet3")
Sheet.Delete
If Dir(fname) <> "" Then Kill (fname)
Sheet.DisplayAlerts = False
Sheet.CheckCompatibility = False
book.SaveAs Filename:=fname, _
FileFormat:=xlExcel8, Password:="", _
ReadOnlyRecommended:=True, CreateBackup:=False
ex.Quit
Next
|