This question already has answers here:
Test or check if sheet exists
(23 answers)
Closed 2 months ago.
I am trying to create multiple worksheet in a workbook and name them based on a contents in a particular table. I am doing this as the list can be dynamic and might need to create more/less sheets depending on the requirement.
Sub CreateSheetsFromList()
Dim NewSheet As Worksheet
Dim x As Integer
Dim tbl As ListObject
Dim cell As Range
Application.ScreenUpdating = False
Set tbl = Worksheets("Sheet1").ListObjects("Table1")
For Each cell In tbl.DataBodyRange.Cells
If SheetExists(cell.Value) = False And cell.Value <> "" Then
Set NewSheet = Sheets.Add(after:=Sheets(Sheets.Count))
NewSheet.Name = cell.Value
End If
Next cell
Application.ScreenUpdating = True
End Sub
Function SheetExists(SheetName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
Set sht = ActiveWorkbook.Worksheets("Sheet1")
On Error GoTo 0
If Not sht Is Nothing Then SheetExists = True
Set sht = Nothing
End Function
Unable to get any kind of results. Please let me know if there is a way to do this in an optimized manner
You have to use the passed variable to check - not a fixed value ("Sheet1"):
Function SheetExists(SheetName As String) As Boolean
Dim sht As Worksheet
On Error Resume Next
'Use the passed SheetName to test for
Set sht = ActiveWorkbook.Worksheets(SheetName)
On Error GoTo 0
If Not sht Is Nothing Then SheetExists = True
End Function
Add Sheets From Excel Table (ListObject)
Utilization
Sub AddSheetsFromListObjectTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
AddSheetsFromListObject wb, "Sheet1", "Table1", 1
End Sub
The Method
Sub AddSheetsFromListObject( _
ByVal wb As Workbook, _
ByVal WorksheetID As Variant, _
ByVal ListObjectID As Variant, _
ByVal ListColumnID As Variant)
Const PROC_TITLE As String = "Create Sheets From ListObject"
On Error GoTo ClearError
Dim sws As Worksheet: Set sws = wb.Sheets(WorksheetID)
Dim slo As ListObject: Set slo = sws.ListObjects(ListObjectID)
Dim slc As ListColumn: Set slc = slo.ListColumns(ListColumnID)
Dim srg As Range: Set srg = slc.DataBodyRange
Dim dws As Worksheet, sCell As Range, dName As String, NotRenamed As Boolean
For Each sCell In srg.Cells
dName = CStr(sCell.Value)
If dws Is Nothing Then
Set dws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
End If
On Error GoTo RenameError
dws.Name = dName
On Error GoTo ClearError
If NotRenamed Then NotRenamed = False Else Set dws = Nothing
Next sCell
If Not dws Is Nothing Then
Application.DisplayAlerts = False
dws.Delete
Application.DisplayAlerts = True
End If
ProcExit:
Exit Sub
RenameError:
'Debug.Print "Name = """ & dName & """" & vbLf & Left(Err.Description, 48)
NotRenamed = True
Resume Next
ClearError:
MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
& Err.Description, vbCritical, PROC_TITLE
Resume ProcExit
End Sub
How do you create a range in code and using those name ranges to find the average and then displaying that value into a certain cell
I am trying my hardest!!
My Code:
Sub NameRanges()
Dim HourlyConsumption As Range
Set HourlyConsumption = Range("B2:B251")
ThisWorkbook.Names.Add name:="HourlyConsumption", RefersTo:=HourlyConsumption
Dim Replenishment As Range
Set Replenishment = Range("C2:C251")
ThisWorkbook.Names.Add name:="Replenishment", RefersTo:=Replenishment
End Sub
Sub DataAverages()
Dim AVGHourlyConsumption As Double
Dim AVGReplenishment
AVGHourlyConsumption = (Range("HourlyConsumption").Value) / ("HourlyConsumption")
AVGReplenishment = (Range("Replenishment").Value) / ("Replenishment")
Set AVGHourlyConsumption.Value = Cells("H1")
Set AVGReplenishment.Vaule = Cells("H2")
End Sub
Add Named Range
Option Explicit
Sub DoTheJob() ' rename appropriately!
NameRanges
PopulateAverages
End Sub
Sub NameRanges()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1") ' adjust!
' Use the 'AddNamedRange' method to safely add the named ranges:
AddNamedRange "HourlyConsumption", "B2:B251", sws
AddNamedRange "Replenishment", "C2:C251", sws
End Sub
Sub PopulateAverages()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Note that this worksheet can be different
' than the worksheet containing the named ranges.
Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet1") ' adjust!
' Formulas
With dws.Range("H1")
.Formula = "=IFERROR(AVERAGE(HourlyConsumption),"""")"
'.NumberFormat = "0.0000"
'.Font.Bold = True
'.Interior.Color = vbYellow
End With
With dws.Range("H2")
.Formula = "=IFERROR(AVERAGE(Replenishment),"""")"
'.NumberFormat = "0.0000"
'.Font.Bold = True
'.Interior.Color = vbYellow
End With
' Values
' With dws.Range("H1")
' .Value = dws.Evaluate("IFERROR(AVERAGE(HourlyConsumption),"""")")
' End With
' With dws.Range("H2")
' .Value = dws.Evaluate("IFERROR(AVERAGE(Replenishment),"""")")
' End With
End Sub
Sub AddNamedRange( _
ByVal RangeName As String, _
ByVal RangeAddress As String, _
ByVal WorksheetObject As Worksheet, _
Optional ByVal ApplyWorksheetScope As Boolean = False)
With WorksheetObject
On Error Resume Next
.Parent.Names(RangeName).Delete
On Error GoTo 0
If ApplyWorksheetScope Then
.Names.Add RangeName, .Range(RangeAddress)
Else
.Parent.Names.Add RangeName, .Range(RangeAddress)
End If
End With
End Sub
Sub Auto_Open()
Dim ComboBox2 As Object
Dim ws As Worksheet
Dim rng As Range
Const cCount As Long = 2
Set ws = ActiveSheet(1)
With ws
Set rng = .Range("H10")
Set ComboBox2 = .Shapes.AddFormControl(xlDropDown, _
Left:=rng.Left, _
Top:=rng.Top, _
Width:=rng.Width, _
Height:=rng.Height)
With ComboBox2
.ControlFormat.DropDownLines = 100
.Name = "myCombo"
End With
With Worksheets(5)
Dim erg As Range: Set erg = .Range("D6", .Range("D" & .Rows.Count) _
.End(xlUp)).Resize(, cCount)
Worksheets(1).ComboBox2.ColumnCount = cCount
Worksheets(1).ComboBox2.List = erg.Value
End With
End Sub
This code is in the workbook.
I am trying to create a combobox when someone opens this file and then have it to be populated from worsheet 5.
Its not happening, nothing is created and im also not getting any errors.
Try using Workbook_Open event instead of Auto_Open event (it exist for backwards compatibility), the code should be placed in ThisWorkbook object.
Private Sub Workbook_Open()
Dim ComboBox2 As Object
Dim ws As Worksheet
Dim rng As Range
Const cCount As Long = 2
Set ws = ActiveSheet 'Avoid using ActiveSheet, replace this with the worksheet name instead
With ws
Set rng = .Range("H10")
Set ComboBox2 = .Shapes.AddFormControl(xlDropDown, _
Left:=rng.Left, _
Top:=rng.Top, _
Width:=rng.Width, _
Height:=rng.Height)
End With
With ComboBox2
.ControlFormat.DropDownLines = 100
.Name = "myCombo"
End With
With Worksheets(5)
Dim erg As Range
Set erg = .Range("D6", .Range("D" & .Rows.Count) _
.End(xlUp)).Resize(, cCount)
End With
With Worksheets(1).ComboBox2
.ColumnCount = cCount
.List = erg.Value
End With
End Sub
Option Explicit
Sub ExtractDivFromAastocks()
Dim StockCode As String, Anchor As String
Dim ws As Worksheet
StockCode = "02800"
Anchor = "Announce Date"
Set ws = ExtractRawDivFromAastocks(StockCode)
Call CleanAastocksDiv(StockCode, ws)
End Sub
Private Function ExtractRawDivFromAastocks(StockCode As String)
Dim WsFound As Boolean
Dim i As Integer
WsFound = False
For i = 1 To Sheets.Count():
If Worksheets(i).Name = StockCode Then
WsFound = True
End If
If WsFound = True Then
Exit For
End If
Next i
If WsFound = True Then
Application.DisplayAlerts = False
Worksheets(StockCode).Delete
Application.DisplayAlerts = True
End If
Dim ws As Worksheet
Dim qt As QueryTable
Dim Website As String, Aastock As String
Aastock = "http://www.aastocks.com/en/stocks/analysis/dividend.aspx?symbol="
Website = Aastock & StockCode
Set ws = Sheets.Add(After:=Worksheets(Worksheets.Count()))
ws.Name = StockCode
Set qt = ws.QueryTables.Add( _
Connection:="URL;" & Website, _
Destination:=ws.Range("A1"))
With qt
.RefreshOnFileOpen = True
.Refresh
End With
Set ExtractRawDivFromAastocks = ws
End Function
Private Sub CleanAastocksDiv(StockCode As String, ws As Worksheet)
Dim StartRow As Integer
StartRow = Application.Match("Announce Date", ws.Range("A:A"), 0)
ws.Range("A1:" & _
ws.Cells(StartRow - 1, ws.Columns.Count()).Address).EntireRow.Delete
End Sub
The worksheet indeed has the string value in it, and I have no idea why the match fails. I have tried using the Match function on the sheet itself, it works. Could this be some kind of reference issues? The cell in the sheet doesn't seem to have weird whitespaces. It would be really great if anyone can help me with this:
Public Sub TestMe()
Dim ws As Worksheet: Set ws = Worksheets(1)
Dim StartRow As Variant
StartRow = Application.Match("Announce Date", ws.Range("A:A"), 0)
If IsError(StartRow) Then Exit Sub
If StartRow < 2 Then Exit Sub
ws.Range("A1:A" & StartRow - 1).EntireRow.Delete
End Sub
Declare StartRow as a Variant, because if Announce Date does not exist, it would return an error;
It can be checked with the IsError(StartRow) and exit if it is not the case;
If StartRow < 2 Exit Sub is needed to avoid a possible error if StartRow is 1;
What is the most reliable and efficient way to trim all sheets of an Excel file of empty formatting?
I consider the Used Range to be all cells with visible data and objects, excluding Comments.
Reliability aspects:
Preserve all visible data (with its formatting) and formulas on all sheets
Preserve objects on all sheets: charts, pivot tables, and list objects (data tables)
Graphics to remain exactly the same position, size and all other properties after the cleanup
Remove all blank cells with old formatting or empty strings that generate a "false" Used Range
These can be cells that were previously used but their data was removed
Invalid formulas, or invisible characters like an untrimmed strings or carriage returns
The solution should also remove all invalid Names (containing the string "#REF!")
Cleanup conditional formatting rules on all sheets removing duplicate rules for the same columns
Clean excess formatting on workbooks and sheets unprotected or protected without a password
A solution with more coverage than the one provided by Microsoft on this page
How to reset the last cell in Excel
The code in the Excel Add-in available in this answer
I'm providing my own attempt to cover the requirements, as a reference
Paste code in a new VBA module and run the first procedure (trimXL)
.
Option Explicit
Private pb01 As Boolean, pb02 As Boolean 'protected attribs of WB & WS
Private ps01 As Boolean, ps02 As Boolean, ps03 As Boolean, ps04 As Boolean
Private ps05 As Boolean, ps06 As Boolean, ps07 As Boolean, ps08 As Boolean
Private ps09 As Boolean, ps10 As Boolean, ps11 As Boolean, ps12 As Boolean
Private ps13 As Boolean, ps14 As Boolean, ps15 As Boolean, ps16 As Boolean
Private isWBProtected As Boolean
Private shapeInfo As Object
Public Function trimXL() As Boolean
Dim wb As Workbook, ws As Worksheet, sCnt As Long, shapesOnWS As Long
Dim lastCel As Range, urAll As Range, thisActWS As Worksheet, isGo As Boolean
Dim lrAll As Long, lcAll As Long, lrDat As Long, lcDat As Long, msg As String
Dim emptyRows As Range, emptyCols As Range, sz1 As Single, sz2 As Single
enableXL False
Set wb = ThisWorkbook
If wbIsReady(wb) Then
Set thisActWS = wb.ActiveSheet
removeInvalidNames
sz1 = FileLen(wb.FullName) / 1024
For Each ws In wb.Worksheets
isGo = IIf(isWBProtected, canUnprotectWs(ws), True)
If isGo Then
Set urAll = ws.UsedRange
lrAll = urAll.Rows.Count + urAll.Row - 1
lcAll = urAll.Columns.Count + urAll.Column - 1
If 0 Then unhideRows ws, urAll
removeXLErrors ws.UsedRange
trimWhiteSpaces ws
Set shapeInfo = newDictionary
shapesOnWS = persistShapesInfo(ws)
trimListObjects ws
Set lastCel = GetMaxCell(urAll)
lrDat = lastCel.Row
lcDat = lastCel.Column
Set emptyRows = ws.Range(ws.Cells(lrDat + 1, 1), ws.Cells(lrAll + 1, 1))
Set emptyCols = ws.Range(ws.Cells(1, lcDat + 1), ws.Cells(1, lcAll + 1))
'setStandardSize ws, emptyRows, emptyCols
If (lrDat = 1 And lcDat = 1) Or (lrAll <> lrDat Or lcAll <> lcDat) Then
If lrDat = 1 And lcDat = 1 And Len(lastCel.Value2) = 0 Then
urAll.EntireRow.Delete
If lrAll <> lrDat Or lcAll <> lcDat Then sCnt = sCnt + 1
Else
If lrAll <> lrDat Or lcAll <> lcDat Then
If lrAll <> lrDat Then emptyRows.EntireRow.Delete
If lcAll <> lcDat Then emptyCols.EntireColumn.Delete
sCnt = sCnt + 1
End If
End If
End If
If shapesOnWS > 0 Then resetShapesInfo ws
'resetConditionalFormatting
If isWBProtected Then protectWs ws
End If
Next
activateFirstCell ws
thisActWS.Activate
If isWBProtected Then protectWB wb
sz2 = FileLen(wb.FullName) / 1024
'wb.Save
Set thisActWS = Nothing
Set shapeInfo = Nothing
End If
enableXL
msg = msg & " File '" & wb.Name & "' cleaned" & vbNewLine & vbNewLine
msg = msg & " Size" & vbTab & "Before: " & vbTab & sz1 & " Kb" & vbNewLine
msg = msg & vbTab & " After: " & vbTab & sz2 & " Kb" & vbNewLine & vbNewLine
msg = msg & vbTab & "Trimmed Sheets" & vbTab & sCnt & vbTab & vbNewLine & vbNewLine
MsgBox msg, vbInformation, " Trim Completed: """ & wb.Name & """"
End Function
'Sheet Functions -----------------------------------------------------------------------
Private Sub activateFirstCell(ByRef ws As Worksheet)
If ws Is Nothing Then Set ws = ThisWorkbook.ActiveSheet
Application.Goto ws.Cells(1), True
'ws.Activate: ws.Cells(1).Activate
End Sub
Private Sub setStandardSize(ByRef ws As Worksheet, ByRef eRows As Range, eCols As Range)
eRows.EntireColumn.ColumnWidth = ws.StandardWidth
eCols.EntireColumn.ColumnWidth = ws.StandardWidth
eRows.EntireRow.RowHeight = ws.StandardHeight
eCols.EntireRow.RowHeight = ws.StandardHeight
End Sub
Public Sub unhideRows(ByRef ws As Worksheet, ByRef rng As Range)
If ws Is Nothing Then Set ws = ThisWorkbook.ActiveSheet
If rng Is Nothing Then Set rng = ws.UsedRange
If Not ws.AutoFilter Is Nothing Then
With ws.AutoFilter
If .FilterMode Then If .Filters.Count = 1 Then rng.AutoFilter
End With
End If
rng.Rows.EntireRow.Hidden = False
rng.Columns.EntireColumn.Hidden = False
End Sub
Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range
'It returns the last cell of range with data, or A1 if Worksheet is empty
Const NONEMPTY As String = "*"
Dim lRow As Range, lCol As Range
If rng Is Nothing Then Set rng = Application.ThisWorkbook.ActiveSheet.UsedRange
If WorksheetFunction.CountA(rng) = 0 Then
Set GetMaxCell = rng.Parent.Cells(1, 1)
Else
With rng
Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
after:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByRows)
Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
after:=.Cells(1, 1), _
SearchDirection:=xlPrevious, _
SearchOrder:=xlByColumns)
Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
End With
End If
End Function
Public Sub trimWhiteSpaces(ByRef ws As Worksheet) 'Blanks ----------------------------
Dim i As Byte
With ws.UsedRange
For i = 1 To 10
.Replace What:=Space(i), Replacement:=vbNullString, LookAt:=xlWhole
Next
.Replace What:=vbTab, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbCrLf, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbCr, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbLf, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbNewLine, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbNullChar, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbBack, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbFormFeed, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbVerticalTab, Replacement:=vbNullString, LookAt:=xlWhole
.Replace What:=vbObjectError, Replacement:=vbNullString, LookAt:=xlWhole
End With
End Sub
Public Sub trimListObjects(ByRef ws As Worksheet) 'tables
Dim tbl As ListObject, lastCel As Range, lrDat As Long, lcDat As Long
For Each tbl In ws.ListObjects
With tbl
lcDat = .ListColumns.Count
If .Range.Count <> (.ListRows.Count * lcDat) Then
Set lastCel = GetMaxCell(.Range)
lrDat = lastCel.Row - .Range.Row + 1
If lrDat = 1 Then .Delete Else .Resize .Range.Resize(lrDat + 1, lcDat)
End If
End With
Next
End Sub
Public Sub removeXLErrors(ByRef ur As Range) 'All errors ----------------------------
Dim i As Byte, xlError() As String
On Error Resume Next
ur.SpecialCells(xlCellTypeFormulas, xlErrors).Clear
If 0 Then
ReDim xlError(6)
xlError(0) = "#DIV/0!" 'Excel.XlCVError.xlErrDiv0 = 2007 => #DIV/0!
xlError(1) = "#N/A" 'Excel.XlCVError.xlErrNA = 2042 => #N/A
xlError(2) = "#NAME?" 'Excel.XlCVError.xlErrName = 2029 => #NAME?
xlError(3) = "#NULL" 'Excel.XlCVError.xlErrNull = 2000 => #NULL
xlError(4) = "#NUM!" 'Excel.XlCVError.xlErrNum = 2036 => #NUM!
xlError(5) = "#REF" 'Excel.XlCVError.xlErrRef = 2023 => #REF
xlError(6) = "#VALUE!" 'Excel.XlCVError.xlErrValue = 2015 => #VALUE!
'VBA.Conversion.CVErr 1 / 0
'Public Const EXCEL_ERROR As String = "#N/A"
For i = 0 To 6
ur.Replace What:=xlError(i), Replacement:=vbNullString, LookAt:=xlWhole
Next
End If
End Sub
Public Sub resetConditionalFormatting(Optional ByRef rng As Range = Nothing)
Const F_ROW As Long = 2
Dim ws As Worksheet, ur As Range, maxCol As Long, maxRow As Long, thisCol As Long
Dim colRng As Range, fcCol As Range, fcCount As Long, fcAdr As String
If rng Is Nothing Then Set rng = Application.ThisWorkbook.ActiveSheet.UsedRange
Set ws = ThisWorkbook.ActiveSheet
Set ur = ws.UsedRange
maxRow = ur.Rows.Count
maxCol = ur.Columns.Count
For Each colRng In ws.Columns
If colRng.Column > maxCol Then Exit For
thisCol = thisCol + 1
Set fcCol = ws.Range(ws.Cells(F_ROW, thisCol), ws.Cells(maxRow, thisCol))
With colRng.FormatConditions
If .Count > 0 Then
fcCount = 1
fcAdr = .Item(fcCount).AppliesTo.Address
While fcCount <= .Count
If .Item(fcCount).AppliesTo.Address = fcAdr Then
.Item(fcCount).ModifyAppliesToRange fcCol
fcCount = fcCount + 1
Else
On Error Resume Next
.Item(fcCount).Delete
End If
Wend
End If
End With
Next
End Sub
'Workbook Functions --------------------------------------------------------------------
Public Sub removeInvalidNames()
Dim itm As Name
With ThisWorkbook
If .Names.Count > 0 Then
On Error Resume Next
Err.Clear
For Each itm In .Names
If InStr(itm.RefersTo, "#REF!") > 0 Then itm.Delete
Next
End If
'xlResetSettings
.Saved = True
End With
End Sub
'Shape Functions -----------------------------------------------------------------------
Public Function newDictionary(Optional ByRef dictObj As Object, _
Optional ByVal caseSensitive As Boolean = False) As Object
If Not dictObj Is Nothing Then Set dictObj = Nothing
'Set dictionaryObject = New Dictionary
Set dictObj = CreateObject("Scripting.Dictionary")
dictObj.CompareMode = IIf(caseSensitive, vbBinaryCompare, vbTextCompare)
Set newDictionary = dictObj
End Function
Private Function persistShapesInfo(ByRef ws As Worksheet) As Long
Dim sh As Shape, totalShapes As Long
For Each sh In ws.Shapes
If Not sh.Type = msoComment Then
With sh
shapeInfo(.Name) = .Top & "|" & .Left & "|" & .Height & "|" & .Width
shapeInfo(.Name) = shapeInfo(.Name) & "|" & .Placement
.Placement = xlFreeFloating
End With
totalShapes = totalShapes + 1
End If
Next
persistShapesInfo = totalShapes
End Function
Private Sub resetShapesInfo(ByRef ws As Worksheet)
Dim sh As Variant, shInfo As Variant
For Each sh In shapeInfo
shInfo = Split(shapeInfo(sh), "|")
With ws.Shapes(sh)
.Top = shInfo(0)
.Left = shInfo(1)
.Height = shInfo(2)
.Width = shInfo(3)
.Placement = shInfo(4)
End With
Next
End Sub
'Excel Functions -----------------------------------------------------------------------
Public Sub enableXL(Optional ByVal opt As Boolean = True)
With Application
.Calculation = IIf(opt, xlCalculationAutomatic, xlCalculationManual)
.DisplayAlerts = opt
.DisplayStatusBar = opt
.EnableAnimations = opt
.EnableEvents = opt
.ScreenUpdating = opt
End With
enableWS , opt
End Sub
Public Sub enableWS(Optional ByVal ws As Worksheet, Optional ByVal opt As Boolean =True)
If ws Is Nothing Then
For Each ws In Application.ActiveWorkbook.Sheets
setWS ws, opt
Next
Else
setWS ws, opt
End If
End Sub
Private Sub setWS(ByVal ws As Worksheet, Optional ByVal opt As Boolean = True)
With ws
.DisplayPageBreaks = False
.EnableCalculation = opt
.EnableFormatConditionsCalculation = opt
.EnablePivotTable = opt
End With
End Sub
Public Sub xlResetSettings() 'default Excel settings
With Application
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.DisplayStatusBar = True
.EnableAnimations = False
.EnableEvents = True
.ScreenUpdating = True
Dim sh As Worksheet
For Each sh In Application.ActiveWorkbook.Sheets
With sh
.DisplayPageBreaks = False
.EnableCalculation = True
.EnableFormatConditionsCalculation = True
.EnablePivotTable = True
End With
Next
End With
End Sub
'Protection Functions ------------------------------------------------------------------
Private Function wbIsReady(ByRef wb As Workbook) As Boolean
isWBProtected = wbIsProtected(wb)
wbIsReady = canUnprotectWb(wb)
End Function
Private Function wbIsProtected(ByRef wb As Workbook) As Boolean
Dim hasPassword As Boolean, ws As Worksheet
If Not wb.ReadOnly Then
pb01 = wb.ProtectStructure
pb02 = wb.ProtectWindows
hasPassword = pb01 Or pb02
For Each ws In wb.Worksheets
hasPassword = hasPassword Or wsIsProtected(ws)
If hasPassword Then Exit For
Next
End If
wbIsProtected = hasPassword
End Function
Private Function wsIsProtected(ByRef ws As Worksheet) As Boolean
With ws
ps01 = .ProtectContents
ps02 = .ProtectDrawingObjects
With .Protection
ps03 = .AllowDeletingColumns
ps04 = .AllowDeletingRows
ps05 = .AllowEditRanges.Count > 0
ps06 = .AllowFiltering
ps07 = .AllowFormattingCells
ps08 = .AllowFormattingColumns:
ps09 = .AllowFormattingRows
ps10 = .AllowInsertingColumns
ps11 = .AllowInsertingHyperlinks
ps12 = .AllowInsertingRows
ps13 = .AllowSorting
ps14 = .AllowUsingPivotTables
End With
ps15 = .ProtectionMode
ps16 = .ProtectScenarios
End With
wsIsProtected = ps01 Or ps02 Or ps03 Or ps04 Or ps05 Or ps06 Or ps07 Or ps08 Or _
ps09 Or ps10 Or ps11 Or ps12 Or ps13 Or ps14 Or ps15 Or ps16
End Function
Private Sub protectWB(ByRef wb As Workbook)
If Not wb.ReadOnly Then wb.Protect vbNullString, pb01, pb02
End Sub
Private Sub protectWs(ByRef ws As Worksheet)
ws.Protect vbNullString, ps02, ps01, ps16, True, ps07, ps08, _
ps09, ps10, ps12, ps11, ps03, ps04, ps13, ps06, ps14
End Sub
Private Function canUnprotectWb(ByRef wb As Workbook) As Boolean
Dim hasPassword As Boolean
hasPassword = True
On Error Resume Next
wb.Unprotect vbNullString
If Err.Number = 1004 Then
Err.Clear
hasPassword = True
End If
canUnprotectWb = hasPassword
End Function
Private Function canUnprotectWs(ByRef ws As Worksheet) As Boolean
Dim hasPassword As Boolean
hasPassword = True
On Error Resume Next
ws.Unprotect vbNullString
If Err.Number = 1004 Then
Err.Clear
hasPassword = False
End If
canUnprotectWs = hasPassword
End Function
More details about cleaning up conditional formatting rules in this SO answer