VBA Code runs inconsistently - vba

Hi there i have this code that allows cells in one sheet to be deleted , thereafter, the deletion would be updated in another sheet. This code has been running well until today when i tried again it kept giving me errors at
Set delRange = Union(delRange, .Cells(j, i)). The error message is "Method'Union' of object_'Global'failed"
I tried it on other workbooks and at first it worked, subsequently it gave the same error again . May i know why am i getting this error and are there any solutions to debug this ?Thank you
Sub Database()
Dim rng As Range, rngError As Range, delRange As Range
Dim i As Long, j As Long, k As Long
Dim wks As Worksheet
On Error Resume Next
Set rng = Application.InputBox("Select cells To be deleted", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub Else rng.Delete
For k = 1 To ThisWorkbook.Worksheets.Count 'runs through all worksheets
Set wks = ThisWorkbook.Worksheets(k)
With wks
For i = 1 To 7 '<~~ Loop trough columns A to G
'~~> Check if that column has any errors
On Error Resume Next
Set rngError = .Columns(i).SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rngError Is Nothing Then
For j = 1 To 100 '<~~ Loop Through rows 1 to 100
If .Cells(j, i).Text = "#REF!" Then
'~~> Store The range to be deleted
If delRange Is Nothing Then
Set delRange = .Cells(j, i)
Else
Set delRange = Union(delRange, .Cells(j, i))
End If
End If
Next j
End If
Next i
End With
Next k
'~~> Delete the range in one go
If Not delRange Is Nothing Then delRange.Delete
End Sub

Union of ranges in different sheets is not allowed, so the code will fail if it finds "#REF!" in 2 different sheets.
Move:
If Not delRange Is Nothing Then delRange.Delete
Set delRange = Nothing
Before:
Next k

Related

Looping through each cell in a Range

I was writing a program for deleting a row in a Selection with Empty Cell. I wrote the code and it worked well but it have a deficiency.
Code Is:
Dim i As Integer
Dim j As Integer
Dim Num As Integer
Num = Selection.Cells.Count
'MsgBox ("Num of Cells " & Num)
Selection.End(xlUp).Select
If (IsEmpty(ActiveCell)) Then
Selection.End(xlDown).Select
End If
For i = 1 To Num
If (IsEmpty(ActiveCell)) Then
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(-1, 0).EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
Num = Num - 1
On Error GoTo Last
Else
ActiveCell.Offset(1, 0).Select
End If
Next
Last:
Exit
Now I was trying to rewrite the code with looping the cell in Range instead of above For loop:
Dim i As Integer
Dim j As Integer
Dim Num As Integer
Dim myRange As Range
ActiveSheet.Select
Set myRange = Selection.Cells
For Each myRange In Selection
If (IsEmpty(myRange)) Then
ActiveCell.EntireRow.Delete
On Error GoTo Last
Else
'ActiveCell.Offset(1, 0).Select
End If
Next myRange
Last:
Exit
This piece of code is not working Properly. Kindly put your Suggestions and rectify the Code
you could try
If WorksheetFunction.CountBlank(Selection) > 0 Then Intersect(Selection.SpecialCells(xlCellTypeBlanks).EntireRow, Selection.Columns(1)).EntireRow.Delete
Speciealcells seems to be easy to use.
Sub test()
Dim rngDB As Range
Set rngDB = Selection
On Error Resume Next
Set rngDB = rngDB.SpecialCells(xlCellTypeBlanks)
If Err.Number = 0 Then
rngDB.EntireRow.Delete
End If
End Sub
Here is an option that avoids relying on Selection and Select.
You can use a InputBox to determine the range. This will allow you to properly qualify all of your ranges/worksheets. You can then loop through the selected range and determine if the rows should be deleted (if blank).
At the end, delete all the rows at once. On larger operations, this will be much faster since you will only have 1 instance of deletion rather continuously deleting rows in the loop.
Option Explicit
Sub Blanks()
Dim MyRange As Range, MyCell As Range, DeleteMe As Range
Set MyRange = Application.InputBox("Select Range", Type:=8)
For Each MyCell In MyRange
If MyCell = "" Then
If DeleteMe Is Nothing Then
Set DeleteMe = MyCell
Else
Set DeleteMe = Union(DeleteMe, MyCell)
End If
End If
Next MyCell
If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete
End Sub

Check range of Columns in each row and delete row if all columns have no values in them

I want to create a macro that goes through each row in my sheet and checks columns F:I if they have values in them.
If ALL columns are empty then the current row should be deleted.
I tried recycling some code but when I run it, all rows in that sheet get deleted for some reason.
This is the code I have so far:
Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
Dim noValues As Range, MyRange As Range
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)
On Error Resume Next
Set noValues = Intersect(ActiveCell.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0
If noValues Is Nothing Then
Rows(RowToTest).EntireRow.Delete
End If
Next RowToTest
End Sub
You can do this way (it is more efficient to delete rows all in one go using Union):
Option Explicit
Public Sub DeleteRows()
Dim unionRng As Range, rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1") '<== Change to your sheet name
For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)) '<== Column C cells to loop over from row 2 to last row
If Application.WorksheetFunction.CountBlank(rng.Offset(, 3).Resize(1, 4)) = 4 Then 'rng.Offset(, 3).Resize(1, 4)) limits to column F:I. CountBlank function will return number of blanks. If 4 then all F:I columns in that row are blank
If Not unionRng Is Nothing Then
Set unionRng = Union(rng, unionRng) 'gather qualifying ranges into union range object
Else
Set unionRng = rng
End If
End If
Next rng
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete '<== Delete union range object if contains items
Application.ScreenUpdating = True
End Sub
Or this way:
Option Explicit
Public Sub DeleteRows()
Dim unionRng As Range, rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)).Offset(, 3).Resize(.Cells(.Rows.Count, "C").End(xlUp).Row - 1, 4).Rows
On Error GoTo NextLine
If rng.SpecialCells(xlCellTypeBlanks).Count = 4 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(rng, unionRng)
Else
Set unionRng = rng
End If
End If
NextLine:
Next rng
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Try using WorksheetFunction.CountA.
Option Explicit
Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
Dim MyRange As Range
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)
If WorksheetFunction.CountA(MyRange) = 0 Then
MyRange.EntireRow.Delete
End If
Next RowToTest
End Sub
Try the following:
On Error Resume Next
Set noValues = Intersect(myRange.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0
If noValues Is Nothing Then
Rows(RowToTest).EntireRow.Delete
Else
Set noValues = Nothing
End If

Incorporating sheet loop

Hi there i have this code which only runs on a single sheet(sheet3) but i want it to loop through other sheets of the workbook and run this code. I tried using the for each loop but it does not seem to be compatible with this code. Ive looked up other methods of looping but im really unsure of how do i go about it .
Here is the code
Sub DeleteCells()
Dim rng As Range, rngError As Range, delRange As Range
Dim i As Long, j As Long
On Error Resume Next
Set rng = Application.InputBox("Select cells To be deleted", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub Else rng.Delete
With Sheets("Sheet3")
For i = 1 To 7 '<~~ Loop trough columns A to G
'~~> Check if that column has any errors
On Error Resume Next
Set rngError = .Columns(i).SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rngError Is Nothing Then
For j = 1 To 100 '<~~ Loop Through rows 1 to 100
If .Cells(j, i).Text = "#REF!" Then
'~~> Store The range to be deleted
If delRange Is Nothing Then
Set delRange = .Columns(i)
Exit For
Else
Set delRange = Union(delRange, .Columns(i))
End If
End If
Next
End If
Next
End With
'~~> Delete the range in one go
If Not delRange Is Nothing Then delRange.Delete
End Sub
Usually you can loop through sheets using their index #, or the mentioned for each... So added to your code this would mean:
Sub DeleteCells()
Dim rng As Range, rngError As Range, delRange As Range
Dim i As Long, j As Long, k as long
Dim wks as Worksheet
On Error Resume Next
Set rng = Application.InputBox("Select cells To be deleted", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub Else rng.Delete
for k = 1 to thisworkbook.worksheets.count 'runs through all worksheets
set wks=thisworkbook.worksheets(k)
With wks
For i = 1 To 7 '<~~ Loop trough columns A to G
'~~> Check if that column has any errors
On Error Resume Next
Set rngError = .Columns(i).SpecialCells(xlCellTypeFormulas, xlErrors)
On Error GoTo 0
If Not rngError Is Nothing Then
For j = 1 To 100 '<~~ Loop Through rows 1 to 100
If .Cells(j, i).Text = "#REF!" Then
'~~> Store The range to be deleted
If delRange Is Nothing Then
Set delRange = .Columns(i)
Exit For
Else
Set delRange = Union(delRange, .Columns(i))
End If
End If
Next j
End If
Next i
End With
next k
'~~> Delete the range in one go
If Not delRange Is Nothing Then delRange.Delete
End Sub
Usually it is also better to name the "next", because you have a better overview which for...next loop is closed.

Delete row based on fill color index

I am trying to delete all rows with in the range of A7:AI300 that contain a cell with yellow fill (Color index 6) I have some code that will delete all rows that contain the color but the problem I am having is that it is trying to run the code for the whole worksheet and will freeze my workbook. I am trying to insert a range to speed up the calculations. Can anyone show me how to insert the range so it works
Sub deleterow()
Dim cell As Range
For Each cell In Selection
If cell.Interior.ColorIndex = 6 Then
cell.EntireRow.Delete
End If
Next cell
End Sub
Is this what you are trying? Notice that we are not deleting each row inside the loop but creating our final "Delete Range" This will ensure that your code runs faster.
EDIT: If you are looking at range "A7:A300" then use this code
Sub deleterow()
Dim cell As Range, DelRange As Range
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A7:A300")
If cell.Interior.ColorIndex = 6 Then
If DelRange Is Nothing Then
Set DelRange = cell
Else
Set DelRange = Union(DelRange, cell)
End If
End If
Next cell
If Not DelRange Is Nothing Then DelRange.EntireRow.Delete
End Sub
And if you are looking at range "A7:AI300" then I guess this is what you want.
Sub deleterow()
Dim cell As Range, DelRange As Range
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("A7:AI300")
If cell.Interior.ColorIndex = 6 Then
If DelRange Is Nothing Then
Set DelRange = cell
Else
Set DelRange = Union(DelRange, cell)
End If
End If
Next cell
If Not DelRange Is Nothing Then DelRange.Delete
End Sub
MORE FOLLOWUP
I think I might have finally understood what you are trying to achieve...
Sub deleterow()
Dim i As Long, j As Long
Dim delRange As Range
With ThisWorkbook.Sheets("Sheet1")
For i = 7 To 300 '<~~ Row 7 to 300
For j = 1 To 35 <~~ Col A to AI
If .Cells(i, j).Interior.ColorIndex = 6 Then
If delRange Is Nothing Then
Set delRange = .Cells(i, j)
Else
Set delRange = Union(delRange, .Cells(i, j))
End If
Exit For
End If
Next j
Next i
End With
If Not delRange Is Nothing Then delRange.EntireRow.Delete
End Sub
Here is what you can do. Put calculations on manual mode. Set the range you need to delete, instead of selecting...
Sub deleterow()
Dim myRange as Range
Dim cell As Range
Application.Calculation = xlCalculationManual
Set myRange = Worksheets(1).Range("A1:A300") '-- just column A would do
For Each cell In myRange
If cell.Interior.ColorIndex = 6 Then
cell.EntireRow.Delete
End If
Next cell
Application.Calculation = xlCalculationAutomatic
End Sub

Delete rows that not contain string in my array

Pls help me modify this code but I would like to keep it 90% the same.
I want to delete the rows that does not contain the array items. So my program deletes rows with a, b in cell. How can I modify the below code so that it erases the other a, b to remain in exec.
myArr = Array("a","b")
For I = LBound(myArr) To UBound(myArr)
'Sheet with the data, you can also use Sheets("MySheet")
With ActiveSheet
'Firstly, remove the AutoFilter
.AutoFilterMode = False
'Apply the filter
.Range("E1:E" & .Rows.Count).AutoFilter Field:=1, Criteria1:=myArr(I)
Set rng = Nothing
With .AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
Next I
This works for me... I have commented the code so you should not have a problem understanding it...
Option Explicit
Dim myArr
Sub Sample()
Dim ws As Worksheet
Dim Lrow As Long, i As Long
Dim rRange As Range, delRange As Range
myArr = Array("a", "b", "c")
Set ws = ThisWorkbook.Sheets("MySheet")
With ws
'~~> Get last row of Sheet
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To Lrow
If Not DoesExists(.Range("A" & i).Value) Then
If delRange Is Nothing Then
Set delRange = .Range("A" & i)
Else
Set delRange = Union(delRange, .Range("A" & i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.EntireRow.Delete
End With
End Sub
Function DoesExists(clVal As Variant) As Boolean
Dim j As Long
For j = LBound(myArr) To UBound(myArr)
If clVal = myArr(j) Then
DoesExists = True: Exit For
End If
Next j
End Function