VBA loop through all worksheets in workbook - excel

I have tried following VBA code, where I want to run this code for all available worksheets in active workbook, I think I am making small mistake and as I am beginner I am not able to find it out, please help to fix it up
Sub ProtectFormulas()
Dim strPassword As String
Dim ws As Worksheet
For Each ws In Sheets
ws.Activate
.Unprotect
.Cells.Locked = False
.Cells.SpecialCells(xlCellTypeFormulas).Locked = True
.Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True
.Protect AllowDeletingRows:=True
strPassword = 123456
ActiveSheet.Protect Password:=strPassword
Next ws
End With
End Sub
Any help would be appriciated by word of thanks.

There are 3 issues with your code:
There is no With block.
The following 2 lines will error if there is no formula in one of the sheets:
.Cells.SpecialCells(xlCellTypeFormulas).Locked = True
.Cells.SpecialCells(xlCellTypeFormulas).FormulaHidden = True
Because if there is no formula then .Cells.SpecialCells(xlCellTypeFormulas) is Nothing and therefore nothing has no .Locked and no .FormulaHidden methods.
You mix using Sheets and Worksheets. Note that those are not the same!
Sheets is a collection of all type of sheets (worksheets, chart sheets, etc)
Worksheets is a collection of only type worksheet
If you declare Dim ws As Worksheet and there is for example a chart sheet in your file, then For Each ws In Sheets will error because you try to push a chart sheet into a variable ws that is defined as Worksheet and cannot contain a chart sheet. Be as specific as possible and use Worksheets whenever possible in favour of Sheets.
The following should work:
Option Explicit
'if this is not variable make it a constant and global so you can use it in any procedure
Const strPassword As String = "123456"
Sub ProtectFormulas()
'Dim strPassword As String
'strPassword = "123456" 'remove this here if you made it global
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
With ws
.Activate 'I think this is not needed
.Unprotect Password:=strPassword 'unprotect probably needs your password too or this will not work once the worksheet was protected.
.Cells.Locked = False
Dim FormulaCells As Range
Set FormulaCells = Nothing 'initialize (because we are in a loop!)
On Error Resume Next 'hide error messages (next line throws an error if no forumla is on the worksheet
Set FormulaCells = .Cells.SpecialCells(xlCellTypeFormulas)
On Error Goto 0 ' re-enable error reporting! Otherwise you won't see errors if they occur!
If Not FormulaCells Is Nothing Then 'check if there were formulas to prevent errors if not
FormulaCells.Locked = True
FormulaCells.FormulaHidden = True
End If
.Protect AllowDeletingRows:=True, Password:=strPassword
End With
Next ws
End Sub

Related

Rename sheet with if sheet name already exists while looping workbooks

I am running my code trying to loop through old and new formatted workbooks.
And the sheet names in my old workbooks are different from the new workbooks.
The code is set to run when the new workbook's names are found.
The old workbooks have sheets named "01", "02" and "03".
The new workbooks have sheets named "newname01", "newname02" and "03".
The code is set to run to "newname01" and "newname02".
What I need to do is if the code runs through an old workbook, change the old sheet names to the new workbook's sheet names and run the code. And when running through a new workbook, run through it without changing the sheet names.
I tried changing the old workbook's sheet names to the new ones at the beginning of the code. But when the code is running through an old workbook, its sheets don't contain the new names the code shows an error.
I tried using -
If Not______Is Nothing then.
But I couldn't figure out how that code works.
my code--->
Sub CD3()
Dim wb As Workbook
For Each wb In Application.Workbooks
If Not Application.ActiveProtectedViewWindow Is Nothing Then
Application.ActiveProtectedViewWindow.Edit
End If
Sheets("newname01").Select
Range("A8:B10").Orientation = 90
Range("C10:D10").Orientation = 90
Range("E8:F10").Orientation = 90
Range("G10:H10").Orientation = 90
Range("I8:J10").Orientation = 90
Range("K10:N10").Orientation = 90
Range("O8:Q10").Orientation = 90
Range("Q8:Q10").FormulaR1C1 = "Observation/ Proposals"
'List Sheet Adding
Sheets.Add After:=Sheets("newname02")
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "03"
'more code
ActiveWindow.Zoom = 75
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Range("A11").Select
ActiveWorkbook.Save
ActiveWorkbook.Close
Next ws
End Sub
When the code is running through an old workbook, it has sheets named "01" and "02". I need to change their name to "newname01" and "newname02" and then run the code.
this is a code I found it changed the code regardles of the name
Sub RenameSheet()
Dim Sht As Worksheet
Dim NewSht As Worksheet
Dim newShtName As String
Set NewSht = ActiveSheet
newShtName = "newname01"
For Each Sht In ThisWorkbook.Sheets
If Sht.Name = "newname02" Then
newShtName = "newname01" & "_" &
ThisWorkbook.Sheets.Count
End If
Next Sht
NewSht.Name = newShtName
End Sub
I only need to Change sheet name "01" to "newname01" and "02" to "newname02". And when it already named "newname01" run the rest of the code.
?I tride using -
If Not______Is Nothing then.
I have a feeling that you are not using proper error handling and hence that line or the one before that where you are setting the worksheet is erroring out. Try something like this (UNTESTED)
Option Explicit
Sub Sample()
Dim wbOld As Workbook
Dim wbNew As Workbook
Dim wsOld As Worksheet
Dim wsNew As Worksheet
Dim wsName As String
'~~> Change these two as applicable
Set wbOld = Workbooks("OldWorkBook")
Set wbNew = Workbooks("NewWorkBook")
'~~> Loop through the worksheets in the old workbook
For Each wsOld In wbOld.Worksheets
'~~> Create the name as per new worksheet
'newname01
wsName = "newname" & wsOld.Name
'~~> Attempt to set it. If the worksheet doesn't
'~~> exists, you will not get an error
On Error Resume Next
Set wsNew = wbNew.Sheets(wsName)
On Error GoTo 0
'~~> Check if the object is not nothing
If Not wsNew Is Nothing Then
'~~> Worksheet exists
'
'~~> Do what you want
'
'~~> This is important to prevent false positives
Set wsNew = Nothing
End If
Next wsOld
End Sub
I Wrote two Codes for the two sheet names. The run the code Below
Sub If_Run()
If Not Application.ActiveProtectedViewWindow Is Nothing Then
Application.ActiveProtectedViewWindow.Edit
End If
'Run_for_newname01() = for workbooks containing a Sheet with "newname01"
'Run_for_01() = for workbooks containing a Sheet with "01"
ws = ActiveWorkbook.Worksheets.Count
For i = 1 To ws
With ActiveWorkbook.Worksheets(i)
If .Name Like "*newname01*" Then
Run_for_newname01
ElseIf .Name Like "*01*" Then
Run_for_01
End If
End With
Next i
End Sub

Delete worksheets if cells below specified strings are empty

I am trying to write a script which will cycle through the worksheets in my workbook and delete the worksheet if the cells directly under the strings "detected", "not detected" and "other" are empty. If there is something entered under any of the three strings the worksheet shouldn't be deleted.
I have some code (below) which will delete the worksheet if a specific cell is empty, but I need to integrate a piece to FIND any of the three strings (if they are there, they will be in column A), and to offset this to check whether the cell below is empty.
Sub DeleteEmptyWorksheets()
Dim MySheets As Worksheet
Application.DisplayAlerts = False
For Each MySheets In ActiveWorkbook.Worksheets
If MySheets.Range(“A1”) = “” Then
MySheets.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
The script will be used in processing COVID19 test results, so if you can help it will be extra karma points!!
Thankyou.
Here's a code that should assist you.
Sub DeleteEmptyWorksheets()
Dim MySheets As Worksheet
Dim rngTest As Range
Dim arTest
Dim blNBFound As Boolean
arTest = Array("detected", "not detected", "other")
Application.DisplayAlerts = False
For Each MySheets In ActiveWorkbook.Worksheets
blNBFound = False
For i = LBound(arTest) To UBound(arTest)
Set rngTest = MySheets.Range("A:A").Find(arTest(i))
If Not rngTest Is Nothing Then
If Len(rngTest.Offset(1, 0)) > 0 Then
blNBFound = True
Exit For
End If
End If
Next i
If blNBFound = False Then MySheets.Delete
Next
Application.DisplayAlerts = True
End Sub

Delete multiple Excel Sheets in VBA

I am using an excel Workbook for programtical generation. Once the workbook is created few of the sheets are having required data and few are blank with default templates only.
I need to delete all sheets having default templates (means no data). I can check specific cell to identify this however need to know how to check for all sheets and then delete sheets one by one.
I am having this piece of code:
Sub TestCellA1()
'Test if the value is cell D22 is blank/empty
If IsEmpty(Range("D22").Value) = True Then
MsgBox "Cell A1 is empty"
End If
End Sub
Try this:
Sub DeleteEmptySheets()
Dim i As Long, ws As Worksheet
' we don't want alerts about confirmation of deleting of worksheet
Application.DisplayAlerts = False
For i = Worksheets.Count To 1 Step -1
Set ws = Worksheets(i)
' check if cell D22 is empty
If IsEmpty(ws.Range("D22")) Then
Sheets(i).Delete
End If
Next
' turn alerts back on
Application.DisplayAlerts = True
End Sub
An alternative implementation using For-Each:
Sub deleteSheets()
Dim wb As Workbook
Dim sht As Worksheet
Set wb = Workbooks("Name of your Workbook")
'Set wb = ThisWorkbook You can use this if the code is in the workbook you want to work with
Application.DisplayAlerts = False 'skip the warning message, the sheets will be deleted without confirmation by the user.
For Each sht In wb.Worksheets
If IsEmpty(sht.Range("D22")) And wb.Worksheets.Count > 1 then
sht.Delete
End If
Next sht
Application.DisplayAlerts = True
End Sub
This mainly serves as a demonstration pf how you can easily loop through worksheets.
As suggested in the comments below by #Darren Bartrup-Cook , the logic according to which the sheets are deleted can and should be modified to not only suit your purposes but to also include safeguards.
Making sure there's always at least one worksheet in the workbook is one of them. This can be ensured in a multitude of ways. I updated my answer to implement one these.

Set Visibility and Invisibility for Two Shapes in all of sheets in Workbook by VBA

I wanna set visibility and invisibility for two shapes at the same time by VBA.
I wrote this code:
Sub Set_Visible_Invisible()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.ActiveSheet.Shapes("btn_S2_Pasive").Visible = False
ws.ActiveSheet.Shapes("btn_S2_Active").Visible = True
Next ws
End Sub
but it's work for only active sheet, not all of the sheets that the workbook has.
Any idea is welcome.
Perhaps:
Sub Set_Visible_Invisible()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
ws.Shapes("btn_S2_Pasive").Visible = False
ws.Shapes("btn_S2_Active").Visible = True
Next ws
End Sub
The key issue is not to double specify the worksheet.

Show comments of certain merged cells in protected mode

I need to show comments in certain merged cells that are unlocked.
I found code online to show all comments in a workbook. This will not work because my workbook needs to be protected, which means the macro will look at locked cells and end prematurely.
Sub Show_Comment()
On Error Resume Next
For Each ws In ActiveWorkbook.Sheets
Set allCommentRng = ws.Cells.SpecialCells(xlCellTypeComments)
For Each Rng In allCommentRng
Rng.Comment.Visible = True
Next
Next
On Error GoTo 0
End Sub
I need to know how to specify a merged range that has a comment. The first merged range is "C7:C8-E7:E8". If I know how to do one range, I will figure our how to do the others.
A picture of what the cell looks like as well as the button:
This not for school.
You must first unprotect worksheet before trying to manipulate it and after changes have been applies, restore protection.
For Each ws In ActiveWorkbook.Sheets
ws.Unprotect
Set allCommentRng = ws.Cells.SpecialCells(xlCellTypeComments)
For Each Rng In allCommentRng
Rng.Comment.Visible = True
Next Rng
ws.Protect
Next ws
Example above implies no password protection. To overcome password protection for worksheets use:
ws.Unprotect Password:="yourpasswordhere"
ws.Protect Password:="yourpasswordhere"
How about if you unprotect the worksheet before you run the macro and re-protect if after:
Sub Show_Comment()
On Error Resume Next
For Each ws In ActiveWorkbook.Sheets
ws.unprotect
Set allCommentRng = ws.Cells.SpecialCells(xlCellTypeComments)
For Each Rng In allCommentRng
Rng.Comment.Visible = True
Next Rng
ws.protect
Next ws
On Error GoTo 0
End Sub

Resources