Delete worksheet if cells are empty - vba

This would be a very simple question.
But I am not sure why this is not working in my excel vba code.
Sheets("I- ABC").Select
If IsEmpty(Range("A3").Value) = True And _
IsEmpty(Range("A4").Value) = True And _
IsEmpty(Range("A5").Value) = True And _
IsEmpty(Range("A6").Value) = True Then
Sheets("I- ABC").Delete
End If

What type of error do you get? I tried this code and Excel displays only warning message:
You can avoid this message by adding:
Application.DisplayAlerts = False
and
Application.DisplayAlerts = True
at the beginning and at the end of your code respectively.
--Edited code
Sub Example()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Application.WorksheetFunction.CountA(.Range("A3:A6")) = 0 Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub

Try Similiar to This
Sub Test()
Application.DisplayAlerts = False
With Sheets("Sheet1")
Columns("A:A").SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
Application.DisplayAlerts = True
End Sub
PS: It works for me and deletes rows containg empty cells in `A:A``
Approach Suggested by #Tim Williams also works for me as per following code in my situation
Sub Test6()
Dim r As Range, rows As Long, i As Long
Set r = ActiveSheet.Range("A3:A6")
rows = r.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(r.rows(i)) = 0 Then r.rows(i).Delete
Next
End Sub
It works even if we use Application instead of WorksheetFunction

If If Application.CountA(Range("A3:A6")) = 0 Then is not working as Tim suggested then that means the cells have blank spaces or unprintable characters.
Try this
Sub Sample()
Dim pos As Long
With Sheets("I- ABC")
pos = Len(Trim(.Range("A3").Value)) + _
Len(Trim(.Range("A4").Value)) + _
Len(Trim(.Range("A5").Value)) + _
Len(Trim(.Range("A6").Value))
If pos = 0 Then
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
Else
MsgBox "The cells are not empty"
End If
End With
End Sub

With skkakkar's idea expanded.
Sub Hello()
Dim rng As Range
Application.DisplayAlerts = 0
On Error GoTo er
Set rng = Range("A3:A6").SpecialCells(xlCellTypeConstants, 23)
Exit Sub
er: MsgBox "ActiveSheet.Delete" 'delete sheet
End Sub

If the spaces are the issue, then you can try this code:
Public Sub RemoveIfEmpty()
Application.DisplayAlerts = False
With Sheets("I- ABC")
If Trim(.Range("A3") & .Range("A4") & .Range("A5") & .Range("A6")) = "" Then
.Delete
End If
End With
Application.DisplayAlerts = True
End Sub

Related

vba end if without block if

I keep getting this error, but can't figure out why. It looks like all rules are followed.
The structure as I read is the following - If -> ElseIf -> End If. But here I get an error though it's all the same.
Sub hide()
Application.ScreenUpdating = False
Dim wRange As Range
Set wRange = Range("A5:B10")
Dim mergedRows As Integer
Dim mergedColumns As Integer
Dim cellFirst As Range
For Each cell In wRange
If IsEmpty(cell) Then
cell.EntireRow.Hidden = True
ElseIf cell.MergeCells Then
mergeRows = cell.MergeArea.Rows.Count
mergeColumns = cell.MergeArea.Columns.Count
With cell.MergeArea
Set cellFirst = cell.MergeArea(Cells(1, 1))
If IsEmpty(cellFirst) Then
cellFirst.EntireRow.Hidden = True
End If
End If
Next
End Sub
You need to also close your With statement.
With cell.MergeArea
Set cellFirst = cell.MergeArea(Cells(1, 1))
If IsEmpty(cellFirst) Then
cellFirst.EntireRow.Hidden = True
End If
End With

Excel keeps crashing with Worksheet_selectionChange

I am running two VBA formulas.
The first hides all cells with empty information the first column.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A49")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A47")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
The second Formula strings data together and placeses this information in the next cell that is empty (aka the first hidden cell) when the button is clicked.
Option Explicit
Dim iwsh As Worksheet
Dim owsh As Worksheet
Dim output As String
Dim i As Integer
Sub Copy()
Set iwsh = Worksheets("Budget")
Set owsh = Worksheets("Release Burnup")
i = 3
While owsh.Cells(i, 1) <> ""
i = i + 1
Wend
output = "R" & iwsh.Cells(13, 2).Value & "-S" & iwsh.Cells(14, 2).Value
owsh.Cells(i, 1) = output
ActiveSheet.EnableCalculation = False
ActiveSheet.EnableCalculation = True
End Sub
Previously, this has been causing no problem... Something has happened that is causing the workbook to crash anytime I try to delete information out of one of the cells with the new data.
PS: This is the list of my other formulas. maybe there is something in these that is interacting with the formentioned code?
Private Sub NewMemberBut_Click()
'causes userform to appear
NewMember.Show
'reformats button because button kept changing size and font
NewMemberBut.AutoSize = False
NewMemberBut.AutoSize = True
NewMemberBut.Height = 40.25
NewMemberBut.Left = 303.75
NewMemberBut.Width = 150
End Sub
'Similar code to the problematic code in question, but this one works fine
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim c As Range
On Error Resume Next
Application.ScreenUpdating = False
For Each c In Range("A3:A35,A41:A80")
If c.Value = vbNullString Then
c.EntireRow.Hidden = True
End If
Next c
For Each c In Range("A3:A35,A41:A80")
If c.Value <> vbNullString Then
c.EntireRow.Hidden = False
End If
Next c
Application.ScreenUpdating = True
End Sub
'Code for UserForm
Option Explicit
Dim mName As String
Dim cName As String
Dim mRole As String
Dim cRole As String
Dim i As Integer
Dim x As Integer
Dim Perc As Integer
Dim Vac As Integer
Dim Prj As Worksheet
Dim Bud As Worksheet
Private Sub NewMember_Initialize()
txtName.Value = ""
cboRoleList.Clear
Scrum.Value = False
txtPercent.Value = ""
txtVacation.Value = ""
txtName.SetFocus
End Sub
Private Sub AddMember_Click()
If Me.txtName.Value = "" Then
MsgBox "Please enter a Member name.", vbExclamation, "New Member"
Me.txtName.SetFocus
Exit Sub
End If
If Me.cboRoleList = "Other" And Me.txtCustomRole = "" Then
MsgBox "Please provide a role name.", vbExclamation, "Other Role"
Exit Sub
End If
If Me.cboRoleList.Value = "" Then
MsgBox "Please select a Role.", vbExclamation, "Member Role"
Me.cboRoleList.SetFocus
Exit Sub
End If
If Me.cboRoleList <> "Other" And Me.txtPercent = "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtPercent.Value > 100 And Me.txtPercent <> "" Then
MsgBox "Please select a valid percentage to be applied to this sprint.", vbExclamation, "Sprint Percent"
Me.txtPercent.SetFocus
Exit Sub
End If
If Me.txtVacation.Value = "" Then
Me.txtVacation.Value = 0
End If
Dim i As Long
Set Prj = Worksheets("Project Team")
Set Bud = Worksheets("Budget")
Prj.Activate
i = 5
x = 1
If Me.cboRoleList.Value = "Other" Then
i = 46
End If
While Prj.Cells(i, 1) <> ""
i = i + 1
Wend
If cboRoleList = "Other" Then
Cells(i, x).Value = txtCustomRole.Value
End If
If cboRoleList <> "Other" Then
Cells(i, x).Value = cboRoleList.Value
End If
x = x + 1
Cells(i, x).Value = txtName.Value
x = x + 1
If Me.cboRoleList.Value <> "Other" Then
Cells(i, x).Value = txtPercent.Value
End If
Unload Me
End Sub
Private Sub CloseBut_Click()
Unload Me
End Sub
Change the event driven Worksheet_SelectionChange to Worksheet_Change and isolate further by only processing when something changes in A3:A49.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A3:A49")) Is Nothing Then
On Error GoTo safe_exit
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim c As Range
For Each c In Intersect(Target, Range("A3:A49"))
c.EntireRow.Hidden = CBool(c.Value = vbNullString)
Next c
End If
safe_exit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Caveat: A Worksheet_Change is not triggered on the change in a cell from the cell's formula. Only by typing, deleting or dragging a cell's contents. Adding or removing a formula will trigger it but not when a formula's result changes from another value somewhere in the workbook changing. This should not affect you as no formula can return vbNullString but it is worth mentioning for others.

Deleting Worksheets if range is blank

I made a code that would delete Worksheets if range "D14:K70" is empty throughout the workbook but I do not know how to ignore "-----------" which are in the worksheet range 72x and empty spaces are 368x. Also I am having an issue at Sheets(i).Delete
Sub DeletingEmptyPages()
Dim i As Long
For i = Sheets.count To 1 Step -1
If WorksheetFunction.CountIf(Sheets(i).Range("D14:K70"), "") >= 368 Then
If Sheets.count > 1 Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
Else
MsgBox "Only 1 sheet left"
Exit Sub
End If
End If
Next i
End Sub
A slightly different way of approaching the same issue. You could add in a do whole loop to stop if it find something as it will speed up the process slightly but the range is so small I don't think it will be an issue.
Sub DeletingEmptyPages()
Dim i As Long
Dim strTestRange As String
Dim bDeleteSheet As Boolean
strTestRange = "D14:K70"
For Each ws In ThisWorkbook.Worksheets
bDeleteSheet = True
For Each c In ws.Range(strTestRange)
If Not (c.Value = "" Or c.Value = "-") Then bDeleteSheet = False
Next c
If bDeleteSheet Then
If Sheets.Count > 1 Then
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Else
MsgBox "Only 1 sheet left"
Exit Sub
End If
End If
Next ws
End Sub
Sub DeletingEmptyPages()
Dim i As Long
For i = Sheets.count To 1 Step -1
If WorksheetFunction.CountA(Sheets(i).Range("D14:K25, D27:K27, D29:K31, D34:K34, D36:K52, D55:K55, D57:K57, D59:K66, D68:K68, D70:K70 "), "") >= 368 Then
If Sheets.count > 1 Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
Else
MsgBox "Only 1 sheet left"
Exit Sub
End If
End If
Next i
End Sub

Faster multiple criteria search/filter excel

Hi guys I made the code below to search for multiple text in a given column. The problem is that it is very slow. Do guys know any other ways to perform it faster?
For example give the array ('foo', 'bar'), The code should iterate on a column and match/filter only the rows that have both texts in any given order.
Sub aTest()
ScreenUpdating = False
Dim selectedRange As Range, cell As Range
Dim searchValues() As String
searchValues = Split(ActiveSheet.Cells(2, 1).Value)
Set selectedRange = Range("A4:A40000")
Dim element As Variant
For Each cell In selectedRange
If cell.Value = "" Then
Exit For
Else
For Each element In searchValues
If Not InStr(1, cell.Value, element) Then
cell.EntireRow.Hidden = True
End If
Next element
End If
Next cell
ScreenUpdating = True
End Sub
I was using it as a filter. copied and pasted the following code with a few modifications. But then I was not able to make the changes to match multiple strings.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim iFilterColumn As Integer
Dim rFilter As Range
Dim sCriteria As String
On Error Resume Next
With Target
Set rFilter = .Parent.AutoFilter.Range
iFilterColumn = .Column + 1 - rFilter.Columns(1).Column
If Intersect(Target, Range("rCriteria")) Is Nothing Then GoTo Terminator
Select Case Left(.Value, 1)
Case ">", "<"
sCriteria = .Value
Case Else
sCriteria = "=*" & .Value & "*"
End Select
If sCriteria = "=" Then
.Parent.Range(rFilter.Address).AutoFilter Field:=iFilterColumn
Else
.Parent.Range(rFilter.Address).AutoFilter Field:=iFilterColumn, Criteria1:=sCriteria
End If
End With
Terminator:
Set rFilter = Nothing
On Error GoTo 0
End Sub
I'm assuming this:
Set selectedRange = Range("A4:A40000")
It's because the size is not defined properly, the following should limit to the right long
Set selectedRange = Range("A4:A" & Cells(Rows.Count, "A").End(xlUp).Row)
If it doesn't affect, I always use these codes to speed up Excel (Instead of only ScreenUpdating alone).
Sub ExcelNormal()
With Excel.Application
.Cursor = xlDefault
.ScreenUpdating = True
.DisplayAlerts = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
End Sub
Sub ExcelBusy()
With Excel.Application
.Cursor = xlWait
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
.StatusBar = False
End With
End Sub
Note: In the future Probably Code Review would be better place to post.

Copying cell with VBA using If statement

I'm a beginner with VBA and I'm wondering how to add a IF ELSE statement to my code:
I only want to enable to copy the cells if the are filled and if they are not filled msgbox must pop-up
code:
Private Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim NextRow As Range
Sheet1.Range("F7,F10,F13,F16,F19,F22,F25,F28").Copy
Sheets("Overzicht").Select
Set NextRow = ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp).Offset(1, 0)
NextRow.Select
Selection.PasteSpecial (xlValues), Transpose:=True
MsgBox "Invoer is opgeslagen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Welcome to stackoverflow.com
You have to wrap your copy code block with a for loop, IF-ELSE statement and a Boolean type variable.
Firstly, you want to iterate over your specified range of cells and make sure they are all filled
Dim allFilled As Boolean
Dim i As Long
For i = 7 To 28 Step 3
If Not IsEmpty(Sheet1.Range("F" & i)) Then
allFilled = True
Else
allFilled = False
End If
Next i
If they are you can proceed with copying-pasting and if they are not the program will show a message box: Not all the cells are filled! Cant copy
your complete code:
Sub CommandButton3_Click()
Application.ScreenUpdating = False
Dim allFilled As Boolean
Dim i As Long
For i = 7 To 28 Step 3
If Not IsEmpty(Sheet1.Range("F" & i)) Then
allFilled = True
Else
allFilled = False
End If
Next i
If allFilled Then ' = if (allFilled = true) then
Dim NextRow As Range
Sheet1.Range("F7,F10,F13,F16,F19,F22,F25,F28").Copy
Sheets("Overzicht").Select
Set NextRow = ActiveSheet.Cells(Cells.Rows.Count, 1).End(xlUp). _
Offset(1, 0)
NextRow.Select
Selection.PasteSpecial (xlValues), Transpose:=True
MsgBox "Invoer is opgeslagen"
Application.CutCopyMode = False
Application.ScreenUpdating = True
Else
MsgBox "Not all the cells are filled! Cant copy"
End If
End Sub
Update, from comments:
Yes, it's possible to execute different checks individually too, for example:
Dim allFilled As Boolean
If Not IsEmpty(Range("F7, F10, F13, F16")) And IsEmpty(Range("F8")) Then
' F7, F10, F13, F16 are not empty and F8 is empty
allFilled = True
ElseIf IsEmpty(Range("F28")) Then
' F28 empty cannot execute copy-paste
allFilled = False
Else
allFilled = False
End If