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
Related
I just want to get the range from A1:A80 from a sheet called "Children" but I debug it, it gets nothing. Here's my code below:
Dim wks2 As Worksheet
Dim children As Range
Worksheets("Children").Activate
Set wks2 = Worksheets("Children")
Set children = wks2.Range("A1:A80")
ResetChild (children) //The sub that I want to call. Explanation bellow.
In the function ResetChild I want to delete all the sheets in my Workbook, that have names equal to the first column of the sheet Children. (A1:A80) So here's my sub below:
Sub ResetChild(children As Range)
Call DisableCalculations
Dim cell As Range
For Each cell In children
Set childrenSheet = Worksheets(cell.Value)
If (DoesSheetExist(childrenSheet)) Then
Application.DisplayAlerts = False
Sheets(childrenSheet).Delete
Application.DisplayAlerts = True
End If
End Sub
Your code should work.
How do you know that it returns nothhing?
put the row in the end of your code
Debug.Print children.Count
if it returns >0 then all ok and children is the range object with data
Maybe try something like this:
Sub DeleteChildren()
Dim children As Range
Dim oChildSheet As Worksheet
Dim vChildName
Set children = ThisWorkbook.Worksheets("Children").Range("A1:A80")
For Each vChildName In children
Set oChildSheet = GetChildSheet(CStr(vChildName))
If Not oChildSheet Is Nothing Then
Application.DisplayAlerts = False
Call oChildSheet.Delete
Application.DisplayAlerts = True
End If
Next vChildName
End Sub
Function GetChildSheet(sChildName As String) As Worksheet
On Error GoTo errHandler
Set GetChildSheet = ThisWorkbook.Worksheets(sChildName)
Exit Function
errHandler:
Debug.Print "Child sheet not found: " & sChildName
End Function
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
I have a folder in that will receive 30 files every day and the file contains multiple sheets and in those sheets, some header starts with Row 1 and some with Row 5. I need apply freeze based on the row header name and I need to run the macro from outside of the folder.
After applying freeze I need to automate the process to send the files to the client.
I tried with below but getting error
"type mismatch souceVBAProject"
Sub FreezePanes()
Call freeze("*.xlsx", "no")
End Sub
Sub freeze(fileName As String, hide As String)
Dim path As String
Dim srcFile As String
On Error GoTo ErrorHandler
path = "C:\Users\RadhaRani\Desktop\Excel\"
srcFile = fileName
Application.ScreenUpdating = False
Dim rng As Range
Dim wks As Workbook
Set wks = Workbooks.Open(path + srcFile)
Set wks = Application.ActiveSheet
For Each ws In Worksheets
ws.Select
Set rng = ActiveCell
Range("A5").Select '<== set Freeze point here
ActiveWindow.FreezePanes = True
rng.Select
Next
wks.Select
ActiveWorkbook.Save
wks.Close
Set wks = Nothing
'If you have shut off ScreenUpdating, you must turn it back on by placing---Application.ScreenUpdating = True---at the top of the code
The top 5 rows are frozen; Note: use the row below the header row.
Application.Goto Cells(6, 1)
ActiveWindow.FreezePanes = True
When attempting to clear a cell range in a hidden worksheet I am receiving a "Select method of range class failed error" on line .Range("A1:EC168").select
Below is a copy of my code, thanks for any advice.
Private Sub ClearAll_Click()
Dim Sheet As Worksheet
Dim CompareTool As Workbook
Dim Sheetname As String
Set CompareTool = ThisWorkbook
With Application
.DisplayAlerts = False
.ScreenUpdating = True
End With
For Each Sheet In CompareTool.Worksheets
If Left(Sheet.Name, 8) = "Scenario" Then
Sheetname = Sheet.Name
With CompareTool.Sheets(Sheetname)
.Visible = True
.Range("A1:EC168").Select
.Visible = False
End With
End If
Next Sheet
Unload Me
End Sub
You will not be able to Select anything on an inactive sheet, so the solution would be to Activate it prior to the Select statement, though since the sheet is hidden, I'm not sure what the benefit of making the selection is...
With Sheet
.Visible = True
.Activate
.Range("A1:EC168").Select
.Visible = False
End With
You don't need to select the range to delete it, just do .Range("A1:EC168").Delete. This way, you don't even need to activate or make it visible:
With Sheet
.Range("A1:EC168").Delete
End With
I have a workbook I have been working on. This workbook has 3 sheets of information that help populate a MASTER sheet through excel index and match functions as well as other functions. The A2 cell on the MASTER sheet is a drop down box of names. As each name is chosen a macro linked to a button helps summarize the information and then an other button copies and paste the sheet to a new sheet in the workbook. My question is on the macro that summarizes the information. Being new to macros, I put this together with information gathered on the Internet. I noticed that it is hiding some rows when used which is not good and works really slow. Also, not of great important, it places the paste anywhere within the range. Even sometimes lines apart, like on E14 and E16 instead of E14 and E15. I am sure there is a better way of writing this macro and any help and education would be greatly appreciated.
Sub UniqueValues()
Dim ws As Worksheet
'list states for install & service
Application.ScreenUpdating = False
Set ws = Sheets("MASTER")
ws.Range("D94:D144").AdvancedFilter Action:=x1FilterInPlace, Unique:=True
Range("D94:D144").Copy
ws.Range("E14:E19").PasteSpecial x1Values
Application.CutCopyMode = False
Application.ScreenUpdating = True
'list states for overrides
Application.ScreenUpdating = False
Set ws = Sheets("MASTER")
ws.Range("D147:D246")AdvancedFilter Action:=x1FilterInPlace, Unique:=True
Range("D147:D246").Copy
ws.Range("E21:E26").PasteSpecial x1Values
Application.CutCopyMode = False
Application.ScreenUpdating = True
'lists states for licenses
Application.ScreenUpdating = False
Set ws = Sheets("MASTER")
ws.Range("D249:D298").AdvancedFilter Action:=x1FilterInPlace, Unique:=True
Range("D249:D298").Copy
ws.Range("E35:E38").PasteSpecial x1Values
Application.CutCopyMode = False
Application.ScreenUpdating = True
'lists states for commissions
Application.ScreenUpdating = False
Set ws = Sheets("MASTER")
ws.Range("D301:D327").AdvancedFilter Action:=x1FilterInPlace, Unique:=True
Range("D301:D327").Copy
ws.Range("E28:E33").PasteSpecial x1Values
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
The 'In Place' filter + copy paste will be very slow. If you want to improve your code you could use a Dictionary (available in the Microsoft Scripting Runtime)
Sub getUniquesValues(output As Range, cells As Range)
Dim cell As Range
Dim knownValues As New Dictionary
For Each cell In cells
If Not knownValues.Exists(cell.Value) Then
output = cell.Value
Set output = output.Offset(1, 0)
knownValues.Add cell.Value, 1
End If
Next
End Sub
Then all you have to do is call the sub this way :
Sub ImprovedUniqueValues()
Dim cell As Range, output As Range
Dim ws As Worksheet
Set ws = Sheets("MASTER")
Set output = ws.Range("E19")
getUniquesValues output, ws.Range("D94", ws.Range("D94").End(xlDown))
....
End Sub