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.
I have a macro that needs to unlock all the sheets in a workbook, run the spell checker, and lock all the sheets (with the original column/cell formatting allowed). The locking errors out each time and I can't figure out why.
I know this doesn't include the formatting aspect, but here's what I've got.
Sub SpellChecker()
'unprotect all sheets
For i = 1 To Sheets.Count
Sheets(i).Unprotect "Password"
Next i
'select all sheets
Dim ws As Worksheet
For Each ws In Sheets
If ws.Visible Then ws.Select (False)
Next
'run spellchecker
Application.CommandBars.FindControl(ID:=2).Execute
'protect sheets
For i = 1 To Sheets.Count
Sheets(i).Protect "Password"
Next i
'selects one sheet/deselect all
Sheets("Sheet1").Select
End Sub
At the point of protecting the sheets, you still have all the sheets selected.
Select just one before
Sheets("Sheet1").Select
'protect sheets
For I = 1 To Sheets.Count
Sheets(I).Protect "Password"
Next I
However, perhaps doing them one sheet at a time is an idea..?
Sub SpellChecker()
For Each ws In Sheets
If ws.Visible Then
ws.Unprotect "Password"
ws.Select
Application.CommandBars.FindControl(ID:=2).Execute
ws.Protect "Password"
End If
Next
End Sub
Here is a method that does not require that the Worksheets ever be unprotected - instead, it will change the Protection on Protected Sheets to allow VBA to edit cells (but not allow the User to edit them) - however, this requires Range.CheckSpelling instead of Application.CommandBars.FindControl(ID:=2).Execute
Sub CheckAllSpelling()
Dim CheckSheet As Worksheet, CheckRange As Range, CheckCell As Range, SheetVisible AS XlSheetVisibility
'Loop through Worksheets in the Workbook
For Each CheckSheet In ThisWorkbook.Worksheets
'Allow VBA to edit a Protected Sheet, but not the User
If CheckSheet.ProtectContents Then CheckSheet.Protect Password:="Password", UserInterfaceOnly:=True
'Filter for Cells with Text to check
On Error Resume Next
Set CheckRange = CheckSheet.UsedRange.SpecialCells(xlCellTypeConstants, xlTextValues)
On Error GoTo 0
'If there are Cells to Check
If Not CheckRange Is Nothing Then
SheetVisible = CheckSheet.Visible
'Loop through cells
For Each CheckCell In CheckRange.Cells
With CheckCell
'If there is a typo, show the cell and Spellcheck it
If Not Application.CheckSpelling(.Text) Then
CheckSheet.Visible= xlSheetVisible
CheckSheet.Activate
.Select
.Show
DoEvents
'This next line is to fix a bug when checking a single cell
CheckSheet.Range(.MergeArea.Address & ", " & .MergeArea.Address) _
.CheckSpelling
End If
End With
Next CheckCell
CheckSheet.Visible= SheetVisible
End If
'Tidy up the Loop
Set CheckRange = Nothing
Next CheckSheet
'Same message as normal Spellcheck
MsgBox "Spell check complete. You're good to go!", vbExclamation
End Sub
(Note the fix for a bug where checking a Single Cell will instead check the entire Sheet)
What I'm trying to setup, is for a user to be able to select a row of text from a table and click on a button to have Excel copy the selection to another worksheet and insert to a non-fixed address. Currently, I tried having it search for a specific text and insert the copied row after that text but I ran into Error 91 "Object variable or With block variable not set." If there is a better way to do this, I'm all ear.
Private Sub CommandButton1_Click()
Selection.Copy
Sheets("Form").Select
Dim FoundRange As Range
Dim RangeAddress As Range
Set FoundRange = Sheet3.Cells.Find("SIGN-ON")
RangeAddress = FoundRange.Address
RangeAddress.Selection
Selection.Insert shift:=xlDown
Sheets("MasterList").Select
End Sub
EDIT: Fixed typo in the code.
You were trying to assign a Range.Address property (a string) into a Range object (e.g. RangeAddress = FoundRange.Address) and Selection is a range, not an action like .Select.
Private Sub CommandButton1_Click()
Dim rngToCopy As Range
Dim FoundRange As Range
Set rngToCopy = Selection 'save the current selection so it won't be lost
With Sheets("Form")
On Error Resume Next
Set FoundRange = .Cells.Find("SIGN-ON")
On Error GoTo 0
If Not FoundRange Is Nothing Then
With FoundRange.Resize(rngToCopy.Rows.Count, rngToCopy.Columns.Count).Offset(1, 0)
rngToCopy.Copy
.Insert shift:=xlDown
Application.CutCopyMode = False
End With
End If
End With
End Sub
I've cut down on the operations by getting rid of relying on .Select. See How to avoid using Select in Excel VBA macros for more methods on getting away from relying on select and activate to accomplish your goals.
A common request in the online forums is for code to identify the unlocked cells within a sheet.
The standard solutions use a loop to iterate through each cell in the used portion of the active worksheet, testing each cell determine if it is locked or not. A code sample for this approach is listed below.
Given the inherent poor performance in looping through cell ranges what superior approaches are possible?
(NB: I do intend to add my own existing approach which was previously hosted on another forum as a potential approach - but I will accept another [suitable] method as the answer if it is provided)
Range Approach to identify unlocked cells
Sub SelectUnlockedCells()
`http://www.extendoffice.com/documents/excel/1053-excel-identify-select-locked-cells.html
Dim WorkRange As Range
Dim FoundCells As Range
Dim Cell As Range
On Error GoTo SelectUnlockedCells_Error
Set WorkRange = ActiveSheet.UsedRange
For Each Cell In WorkRange
If Cell.Locked = False Then
If FoundCells Is Nothing Then
Set FoundCells = Cell
Else
Set FoundCells = Union(FoundCells, Cell)
End If
End If
Next Cell
If FoundCells Is Nothing Then
MsgBox "All cells are locked."
Else
FoundCells.Select
End If
On Error GoTo 0
Exit Sub
SelectUnlockedCells_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure
SelectUnlockedCells of Module Module1"
End Sub
Using SpecialCells to quickly identify unlocked cells
The code below - QuickUnlocked - uses a workaround to quickly generate a SpecialCells collection of error cells to identify the unlocked cell range.
The key code steps are:
Alter the Application to suppress errors, code and screenupdating
Attempt to unlock the ActiveWorkbook and/or the ActiveSheet if they are protected. Exit the code if unsuccessful
Make a replica of the current sheet
Delete any existing formula errors in the replica using SpecialCells
Protect the replica worksheet and with the coverage of error handling, add a deliberate formula error that will only populate the unlocked cells
Clean up and report the results Reset the Application settings
Warning that SpecialCells is restricted to 8192 Areas prior to Xl2010
As per this Microsoft KB article, Excel-2007 and earlier versions supports up to a maximum of 8,192 non-contiguous cells through VBA macros. Rather surprisingly, applying a VBA macro to more than 8192 SpecialCells Areas in these Excel versions, will not raise an error message, and the entire area under consideration will be treated as being part of theSpecialCells` range collection.
Quick Unlocked code
Sub QuickUnlocked()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim lCalc As Long
Dim bWorkbookProtected As Boolean
On Error Resume Next
'test to see if WorkBook structure is protected
'if so try to unlock it
If ActiveWorkbook.ProtectStructure Then
ActiveWorkbook.Unprotect
If ActiveWorkbook.ProtectStructure Then
MsgBox "Sorry, I could not remove the passsword protection from the workbook" _
& vbNewLine & "Please remove it before running the code again", vbCritical
Exit Sub
Else
bWorkbookProtected = True
End If
End If
Set ws1 = ActiveSheet
'test to see if current sheet is protected
'if so try to unlock it
If ws1.ProtectContents Then
ws1.Unprotect
If ws1.ProtectContents Then
MsgBox "Sorry, I could not remove the passsword protection from sheet" & vbNewLine & ws1.Name _
& vbNewLine & "Please remove it before running the code again", vbCritical
Exit Sub
End If
End If
On Error GoTo 0
'disable screenupdating, event code and warning messages.
'set calculation to manual
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
lCalc = .Calculation
.Calculation = xlCalculationManual
End With
On Error Resume Next
'check for existing error cells
Set rng1 = ws1.Cells.SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
'copy the activesheet to a new working sheet
ws1.Copy After:=Sheets(Sheets.Count)
Set ws2 = ActiveSheet
'delete any cells that already contain errors
If Not rng1 Is Nothing Then ws2.Range(rng1.Address).ClearContents
'protect the new sheet
ws2.Protect
'add an error formula to all unlocked cells in the used range
'then use SpecialCells to read the unlocked range address
On Error Resume Next
ws2.UsedRange.Formula = "=NA()"
ws2.Unprotect
Set rng2 = ws2.Cells.SpecialCells(xlCellTypeFormulas, 16)
Set rng3 = ws1.Range(rng2.Address)
ws2.Delete
On Error GoTo 0
'if WorkBook level protection was removed then reinstall it
If bWorkbookProtected Then ActiveWorkbook.Protect
'cleanup user interface and settings
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
lCalc = .Calculation
End With
'inform the user of the unlocked cell range
If Not rng3 Is Nothing Then
MsgBox "The unlocked cell range in Sheet " & vbNewLine & ws1.Name & " is " & vbNewLine & rng3.Address(0, 0)
Else
MsgBox "No unlocked cells exist in " & ws1.Name
End If
End Sub
Well, I've gone back to a loop, but I think this method is efficient because it only references those cells which are Unlocked (without selecting) using Next:
If the object is a range, this property emulates the TAB key, although
the property returns the next cell without selecting it.
On a protected sheet, this property returns the next unlocked cell. On
an unprotected sheet, this property always returns the cell
immediately to the right of the specified cell.
It stores the first (Next) Range.Address, loops through the others until it returns to this first one.
Sub GetUnlockedCells_Next()
Dim ws As Worksheet
Dim strFirst As String
Dim rngNext As Range
Dim strLocked As String
Set ws = Worksheets(1)
ws.Protect
Set rngNext = ws.Range("A1").Next
strFirst = rngNext.Address
Do
strLocked = strLocked & rngNext.Address & ","
Set rngNext = rngNext.Next
Loop Until rngNext.Address = strFirst
strLocked = Left(strLocked, Len(strLocked) - 1) 'remove the spare comma
ws.Range(strLocked).Select
ws.Unprotect
MsgBox strLocked
End Sub
Use Conditional Formatting with:- Use a formula to determine which cells to format, Format values where this formula is true: =CELL("protect",A1)=0 and Format of choice applied to occupied range?
I was looking for a way to clear the contents of my unlocked cells. The problem was that my sheet has hundreds, if not thousands, of unlocked cells and twice as many locked ones. Iterating through them was taking about 5-7 seconds and I wanted something more efficient.
brettdj's solution got me half way there, but having so many cells in my range broke the algorithm.
The line
Set rng3 = ws1.Range(rng2.Address)
Was not working because rng2's address was over the 256 character limit, so rng3 became "nothing".
I spent hours trying to work around the 256 limit but got nowhere. After almost giving up, I stumbled upon the "areas" object of a range. Life saver!
The adjusted code below works with sheets that have several unlocked cells. Thanks to brettdj for the original idea.
' Sub to clear unlocked cells.
Sub clearUnlockedCells()
On Error Resume Next
' If the Workbook is protected, unlock it.
Dim workbook_protected As Boolean
If ActiveWorkbook.ProtectStructure Then
workbook_protected = True
ActiveWorkbook.Unprotect
' If we failed to unlock the Workbook, error out and exit.
If ActiveWorkbook.ProtectStructure Then
MsgBox "Sorry, I could not remove the passsword protection from the workbook" _
& vbNewLine & "Please remove it before running the code again", vbCritical
Exit Sub
End If
End If
Dim source_sheet As Worksheet
Set source_sheet = ActiveSheet
' If the Worksheet is protected, unlock it.
Dim worksheet_protected As Boolean
If source_sheet.ProtectContents Then
worksheet_protected = True
source_sheet.Unprotect
' If we failed to unlock the Worksheet, error out and exit.
If source_sheet.ProtectContents Then
MsgBox "Sorry, I could not remove the passsword protection from sheet" & vbNewLine & source_sheet.name _
& vbNewLine & "Please remove it before running the code again", vbCritical
Exit Sub
End If
End If
On Error GoTo 0
' Disable screenupdating, event code and warning messages.
' Store the calculation and set it to manual.
Dim calc As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
calc = .Calculation
.Calculation = xlCalculationManual
End With
On Error Resume Next
' Check for existing error cells.
Dim tmp_rng As Range
Set tmp_rng = source_sheet.Cells.SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
' Copy the ActiveSheet to a new working sheet.
source_sheet.Copy After:=Sheets(Sheets.Count)
Dim tmp_sheet As Worksheet
Set tmp_sheet = ActiveSheet
' Delete any cells that already contain errors.
If Not tmp_rng Is Nothing Then tmp_sheet.Range(tmp_rng.Address).ClearContents
' Protect the new sheet and add an error formula to all unlocked cells in the
' used range, then use SpecialCells to read the unlocked range address.
tmp_sheet.Protect
On Error Resume Next
tmp_sheet.UsedRange.Formula = "=NA()"
tmp_sheet.Unprotect
' Get the range of cells with "=NA()" in them.
Set tmp_rng = tmp_sheet.Cells.SpecialCells(xlCellTypeFormulas, 16)
' Iterate through the range and create a mirror of that range in the source sheet.
Dim area As Range
Dim source_sheet_range As Range
Dim unlocked_cells As Range
For Each area In tmp_rng.Areas
Set source_sheet_range = source_sheet.Range(area.Address)
If unlocked_cells Is Nothing Then
Set unlocked_cells = source_sheet_range
Else
Set unlocked_cells = Union(unlocked_cells, source_sheet_range)
End If
Next area
' Delete the temp sheet.
tmp_sheet.Delete
On Error GoTo 0
' Protect the Workbook and Worksheet as necessary.
If workbook_protected Then ActiveWorkbook.Protect
If worksheet_protected Then source_sheet.Protect
' Cleanup user interface and settings.
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
.Calculation = calc
End With
' Clean up the unlocked cells.
unlocked_cells.ClearContents
End Sub
Hope that helps someone else. If you just want to select them instead of clearing them, then change the second to last line from .ClearContents to .Select.
Here's a general solution that is much faster than looping through ranges of cells and is much simpler, more straightforward, than cloning temporary worksheets, etc. It is relatively fast because it takes advantage of the high-speed compiled code in which Excel VBA's Find method is implemented.
Function GetUnlockedCells(SearchRange As Range) As Range 'Union
'
'Finds all unlocked cells in the specified range and returns a range-union of them.
'
'AUTHOR: Peter Straton
'
'*************************************************************************************************************
Dim FoundCell As Range
Dim FirstCellAddr As String
Dim UnlockedUnion As Range
'NOTE: When finding by format, you must first set the FindFormat specification:
With Application.FindFormat
.Clear
.Locked = False 'This is the key to this technique
End With
'NOTE: Unfortunately, the FindNext method does not remember the SearchFormat:=True specification so it is
'necessary to capture the address of the first cell found, use the Find method (instead) inside the find-next
'loop and explicitly terminate the loop when the first-found cell is found a second time.
With SearchRange
Set FoundCell = .Find(What:="", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=True)
If Not FoundCell Is Nothing Then
FirstCellAddr = FoundCell.Address
Do
' Debug.Print FoundCell.Address
If UnlockedUnion Is Nothing Then
Set UnlockedUnion = FoundCell.MergeArea 'Include merged cells, if any
Else
Set UnlockedUnion = Union(UnlockedUnion, FoundCell.MergeArea) ' "
End If
Set FoundCell = .Find(What:="", After:=FoundCell, SearchDirection:=xlNext, SearchFormat:=True)
Loop Until FoundCell.Address = FirstCellAddr
End If
End With
Application.FindFormat.Clear 'Cleanup
Set GetUnlockedCells = UnlockedUnion
End Function 'GetUnlockedCells
I was exploring this but I've come full-circle to, more or less, Brett's approach. The slight difference is that I use the current worksheet rather than creating a new one. I'm also initially assuming that there are no errors in the worksheet. (Code could be added similar to Brett's to account for these.)
I wanted to flood the UsedRange with "#N/A", ignore errors, and use Application.Undo to quickly get back. Unfortunately, I couldn't use Undo (unlike in Word). So I resorted to using a Variant to grab the whole area's data, and then re-insert it.
Sub GetUnlockedCells()
Dim ws As Worksheet
Dim rngUsed As Range
Dim varKeep As Variant
Application.ScreenUpdating = False
Set ws = Worksheets(1)
ws.Protect
Set rngUsed = ws.UsedRange
varKeep = rngUsed.Value
On Error Resume Next
rngUsed.Value = "#N/A"
On Error GoTo 0
ws.Unprotect
MsgBox "Unlocked cells are " & _
rngUsed.SpecialCells(xlCellTypeConstants, xlErrors).Address
rngUsed.Value = varKeep
Application.ScreenUpdating = True
End Sub
So, unfortunately, I haven't advanced much beyond Brett's cool code. Maybe it will inspire someone else, or someone might discover a way to use Undo ;)
I'm also losing formulas as well (converted to values) so some work required!
If there are lots of formulas, general approach is
For each row in ...
lockedR = row.locked
for each cell in row
if isnull(lockedR) then ' inconsistent in row
locked = cell.locked
else
locked = lockedR ' consistent from row, no need to get it.
This pattern works fine for many properties such as HasArray. But just for Locked it is grossly (100 times) slower. Don't know why so inefficient.
Goto Special would be a cute trick, but there isn't one for locked cells.
A good solution would be wonderful but I suspect impossible.
I want, in Word VBA, to repeat copying content from Excel to Word.
Goal: I have a range in an Excel workbook about 250 cells long in column C that is a list of figure titles. I want to paste those titles into Word, as ‘captions’ (while leaving space to put the figures later, putting a consistent source caption on them, etc.)
I wrote code for one cell. I want to loop down to the next cell and insert a new caption with that new title, until all 250 distinct titles are entered.
Here is the code. I have it running a function, which runs a sub to get the title from one cell.
Sub Macro123()
Selection.InsertCaption Label:="Figure", TitleAutoText:="InsertCaption2", _
Title:=".", Position:=wdCaptionPositionBelow, ExcludeLabel:=0
Selection.TypeText Text:=TitleDrop
Selection.Style = ActiveDocument.Styles("EcoCaption")
Selection.TypeParagraph
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.TypeParagraph
Selection.TypeText Text:="Source: Current study, based off landings data from CDFW."
Selection.Style = ActiveDocument.Styles("EcoSource")
Selection.TypeParagraph
Selection.TypeParagraph
Selection.TypeParagraph
End Sub
-----------
Function TitleDrop()
GetExcelTitles
Selection.PasteAndFormat (wdFormatPlainText)
End Function
-----------------
Sub GetExcelTitles()
Dim ObjXL As Object, xlWkBk
Dim strTitleName As String
On Error Resume Next
Set ObjXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
MsgBox "No Excel Files are open (Excel is not running)"
Exit Sub
End If
For Each xlWkBk In ObjXL.Workbooks
If xlWkBk.Name = "130611 Figure Lists.xlsx" Then
xlWkBk.Sheets("Figuresonly").Range("C6").Select
xlWkBk.Sheets("Figuresonly").Range("C6").Copy
Exit For
End If
Next
Set ObjXL = Nothing
End Sub
Try changing some of your code to be like the following and make GetExcelTitles call your Paste Sub, not the other way around.
Dim rng as Range
For Each xlWkBk In ObjXL.Workbooks
If xlWkBk.Name = "130611 Figure Lists.xlsx" Then
For each xlWkBk.Sheets("Figuresonly").Range("C1", "C250")
rng.Select
rng.Copy
Call TitleDrop
Next
End If
Next
Cheers, LC