In Excel VBA, I am running into an "error" that halts the macro and a message displays "Code execution has been interrupted." I wrote error in quotations because when I selected debug and examined the line of code that prompted the error, I saw that it was logically sound.
I originally ran into the error at On Error GoTo 0. When I comment out a block around the error, then I get a new line that produces the same error. And, again, when I examine it in debug mode the new "error" is logically sound. Here is the exact line:
If rRange.Row <> 3 And rRange.Row <> 17 Then
FYI, rRange.Row = 3 in this case, so it shouldn't produce an error.
Why is this happening and how can I fix it?
UPDATE Code now produces the error on the End Sub line.
Here is the section that fails:
Sub Review()
Dim WorkRange As Range
Dim FoundCells As Range
Dim Cell As Range
Dim a As String
Dim policy As String
Dim rRange As Range
Set RR = Sheets("Ready for Review")
Set OG = ActiveSheet
OG.Unprotect ("Password")
RR.Activate
On Error Resume Next
Application.DisplayAlerts = False
Set rRange = Application.InputBox(Prompt:= _
"Please select POLICY to review.", _
Title:="SPECIFY POLICY", Type:=8)
On Error GoTo 0
Application.DisplayAlerts = True
If rRange.Row <> 3 And rRange.Row <> 17 Then
MsgBox "Value other than a POLICY was selected. Select the cell that contains the correct policy number."
Exit Sub
Else
policy = rRange.Value
End If
Application.ScreenUpdating = False
OG.Cells(12, 2).Locked = False
Set WorkRange = OG.UsedRange
For Each Cell In WorkRange
If Cell.Locked = False Then
col1 = Cell.Column
Row = Cell.Row
a = OG.Cells(Row, 1)
If Not a = "" Then
row2 = Application.WorksheetFunction.Match(a, RR.Range("A:A"), 0)
Cell.Value = RR.Cells(row2, rRange.Column + col1 - 2)
End If
End If
Next Cell
OG.Unprotect ("Password")
OG.Cells(33, 3).Locked = False
If (Right(OG.Cells(5, 2), 2) = "UL" Or Right(OG.Cells(5, 2), 2) = "IL" Or Right(OG.Cells(5, 2), 2) = "PL") Then
With OG.Cells(33, 3)
.Value = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""Total*"",A:A,0)))-SUM(C34:C37)"
.Locked = True
End With
ElseIf Right(OG.Cells(5, 2), 2) = "WL" Then
With OG.Cells(33, 3)
.Value = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""*"",A:A,0))) - IFERROR(INDEX(C34:C37,MATCH(""Additional"",B34:B37, 0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Paid"",B34:B37,0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Additional Agreement - SPPUA"",B34:B37, 0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Flexible Agreement - FLXT10/20"",B34:B37, 0)),0)"
.Locked = True
End With
Else
With OG.Cells(33, 3)
.Value = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""*"",A:A,0)))"
.Locked = True
End With
End If
OG.Activate
Cells(Application.WorksheetFunction.Match("Last Month Paid ($)", Range("A:A"), 0), 2).NumberFormat = "$#,##0.00;[Red]$#,##0.00"
OG.Protect ("Password")
Application.ScreenUpdating = True
End Sub
Oh, that brings back memories for me. I think I used to get this error about 10 years ago Excel 2003? Maybe?. Excel would get itself into a bit of a state. Nothing was wrong with the code, just it would keep coming back with that error.
If you save your work close Excel and then reopen, does the error go away?
If I remember right, it was caused when I called some external API. Maybe some other API call in your is causing this error but manifesting at this point... perhaps.
Sorry but it was 10+ years ago :)
even if you went through it, you may want to consider the following "restyling" of the code you posted
Option Explicit
Sub Review()
Dim Cell As Range, rRange As Range
Dim a As String
Dim RR As Worksheet, OG As Worksheet
Set RR = Sheets("Ready for Review")
Set OG = ActiveSheet
OG.Unprotect ("Password")
Set rRange = GetUserInpt(RR)
If rRange Is Nothing Then
MsgBox "You aborted the POLICY selection" _
& vbCrLf & vbCrLf _
& "the procedure ends" _
, vbInformation
Exit Sub
End If
Application.ScreenUpdating = False
OG.Cells(12, 2).Locked = False
For Each Cell In OG.UsedRange
With Cell
If Not .Locked Then
a = OG.Cells(.row, 1)
If Not a = "" Then .value = RR.Cells(CLng(Application.WorksheetFunction.Match(a, RR.Range("A:A"), 0)), _
rRange.Column + .Column - 2)
End If
End With
Next Cell
With OG.Cells(33, 3)
.Locked = False
Select Case Right(OG.Cells(5, 2), 2)
Case "UL", "IL", "PL"
.Formula = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""Total*"",A:A,0)))-SUM(C34:C37)"
Case "WL"
.Formula = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""*"",A:A,0))) - IFERROR(INDEX(C34:C37,MATCH(""Additional"",B34:B37, 0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Paid"",B34:B37,0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Additional Agreement - SPPUA"",B34:B37, 0)),0) - IFERROR(INDEX(C34:C37,MATCH(""Flexible Agreement - FLXT10/20"",B34:B37, 0)),0)"
Case Else
.value = "=IF(INDEX(B:B,MATCH(""Total*"",A:A,0))="""",0,INDEX(B:B,MATCH(""*"",A:A,0)))"
End Select
.Locked = True
End With
OG.Activate
Cells(Application.WorksheetFunction.Match("Last Month Paid ($)", Range("A:A"), 0), 2).NumberFormat = "$#,##0.00;[Red]$#,##0.00"
OG.Protect ("Password")
Application.ScreenUpdating = True
End Sub
Function GetUserInpt(sht As Worksheet) As Range
Dim rRange As Range
Application.DisplayAlerts = False
sht.Activate
On Error GoTo InputBoxCanceled
Do While rRange Is Nothing
Set rRange = Application.InputBox(Prompt:="Please select POLICY to review.", _
Title:="SPECIFY POLICY", _
Default:=sht.Cells(3, 1).Address, _
Type:=8)
If rRange.Parent.Name <> sht.Name Then
MsgBox "You must select a cell in '" & sht.Name & "' sheet"
sht.Activate
Set rRange = Nothing
Else
If rRange.row <> 3 And rRange.row <> 17 Then
MsgBox "Value other than a POLICY was selected" _
& vbCrLf & vbCrLf _
& "Select the cell that contains the correct policy number" _
, vbCritical
Set rRange = Nothing
End If
End If
Loop
Set GetUserInpt = rRange
InputBoxCanceled:
On Error GoTo 0
Application.DisplayAlerts = True
End Function
the main revision applies to:
added a GetUserInpt function to handle the policy selection
this function:
checks for both the correct selection row and sheet, too (since it's possible the user shifts to another worksheet during selection!)
runs a loop until the user selects a proper cell
exits selection upon user canceling the InputBox, as the only loop escape possibility
made some simplifications here and there, like:
eliminated Activate statements unless really needed
reduced the amount of variables to only (nearly) strictly needed ones
added some With ... End With blocks to add readability
used a Select Case block instead of an If ... Then ... Else if ... Else ... End if one, for readability again
changed .Value to .Formula, for a proper syntax
all what above could help you with this project and in future ones, too
Could someone please help me with some code to delete all duplicate entries across multiple columns and rows. Any cell which has a duplicate value I'd like to be blank, but I do not want to delete the cell and shift all the rows up like the remove duplicates button does. I'd like code exactly like conditional formatting does to highlight cells, but I'd like to set the value to "" instead.
I'm trying to edit the macro I recorded to something like:
Columns("I:R").Select
selection.FormatConditions.AddUniqueValues
selection.FormatConditions(1).DupeUnique = xlDuplicate
selection.FormatConditions(1).Value = ""
But I'm not sure I'm on the right track
Start at the bottom and work towards the top. Take a ten-column-conditional COUNTIFS function of the cell values while shortening the rows examined by 1 every loop.
Sub clearDupes()
Dim rw As Long
With Worksheets("Sheet1")
If .AutoFilterMode Then .AutoFilterMode = False
With Intersect(.Range("I:R"), .UsedRange)
.Cells.Interior.Pattern = xlNone
For rw = .Rows.Count To 2 Step -1
With .Resize(rw, .Columns.Count) 'if clear both then remove this
If Application.CountIfs(.Columns(1), .Cells(rw, 1), .Columns(2), .Cells(rw, 2), _
.Columns(3), .Cells(rw, 3), .Columns(4), .Cells(rw, 4), _
.Columns(5), .Cells(rw, 5), .Columns(6), .Cells(rw, 6), _
.Columns(7), .Cells(rw, 7), .Columns(8), .Cells(rw, 8), _
.Columns(9), .Cells(rw, 9), .Columns(10), .Cells(rw, 10)) > 1 Then
'test with this
.Rows(rw).Cells.Interior.Color = vbRed
'clear values with this once it has been debugged
'.Rows(rw).Cells.ClearContents
End If
End With 'if clear both then remove this
Next rw
End With
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I've left some code in that only marks the potential duplicates. When you are happy with the results, change that to the commented code that actually clear the cell contents.
Using two sets of nested loops I check each cell in the range twice, once to see if it was a duplicate and to mark it and a second time to then remove the value (ensuring I remove all duplicates and do not leave one instance of each duplicate).
I'm sure that this is an inefficient way of doing it but it works so hopefully helps someone else in the same boat.
Private Sub CommandButton1_Click()
Dim Row As Integer
Dim Column As Integer
Row = 100
Column = 10
'loop through identifying the duplicated by setting colour to blue
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Application.CountIf(Range(Cells(4, 1), Cells(Row, Column)), Cells(i, j)) > 1 Then 'check each cell against entire range to see if it occurs more than once
Cells(i, j).Interior.Color = vbBlue 'if it does sets it to blue
End If
Next j
Next i
'loop through a second time removing the values in blue (duplicate) cells
For i = 1 To Row 'loops each row up to row count
For j = 1 To Column 'loops every column in each cell
If Cells(i, j).Interior.Color = vbBlue Then 'checks if cell is blue (i.e duplicate from last time)
Cells(i, j) = "" 'sets it to blank
Cells(i, j).Interior.Color = xlNone 'changes colour back to no fill
End If
Next j
Next i
End Sub
Use conditional format to highlight duplicates and then change the value to "" using a loop through selection.
This code will allow one value to remain.(if you have 25 twice, this code will keep one 25)
Option Explicit
Sub DupRem()
Application.ScreenUpdating = False
Dim rn As Range
Dim dup As Range
Columns("I:R").FormatConditions.AddUniqueValues
Columns("I:R").FormatConditions(1).DupeUnique = xlDuplicate
Columns("I:R").FormatConditions(1).Font.Color = RGB(255, 255, 0)
For Each rn In Columns("I:R").Cells
If rn <> "" Then
If rn.DisplayFormat.Font.Color = RGB(255, 255, 0) Then
If dup Is Nothing Then
Set dup = rn
Else
Set dup = Union(dup, rn)
End If
End If
End If
Next
dup.ClearContents
Columns("I:R").FormatConditions(1).StopIfTrue = False
Columns("I:R").FormatConditions.Delete
Application.ScreenUpdating = True
End Sub
my newbie question:
I would need to define variable from values gathered by loop.
I have column of datas, and I need to filter those data and copy to another new sheet named with variable.
Problem is, I cannot get variable from loop.
Is it possible?
Example: variable is "hu"
i = 2
Do Until IsEmpty(Cells(i, 9))
**hu** = Cells(i, 9).Value
i = i + 1
Loop
ActiveWorkbook.Worksheets.Add
ActiveSheet.Name = **hu**
Worksheets("Sheet1").Range("A1:I1").Select
Selection.AutoFilter
ActiveSheet.Range("$A$1:$I$1").AutoFilter Field:=9, Criteria1:=**hu**
With ActiveSheet.AutoFilter.Range
On Error Resume Next
Set rng2 = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With
If rng2 Is Nothing Then
MsgBox "No data to copy"
Else
Set rng = ActiveSheet.AutoFilter.Range
rng.Offset(1, 0).Resize(rng.Rows.Count - 1).Copy _
Destination:=Worksheets("Comparison2").Range("A2")
End If
ActiveSheet.ShowAllData
Thanks!
You need to include a subroutine call within your loop to use the variable.
Something like this ..
Option Explicit
Sub do_it()
Dim hu As String
Dim i As Integer
i = 2
Cells(i, 9).Select
Do Until IsEmpty(Cells(i, 9))
hu = Cells(i, 9).Value
get_worksheet (hu)
i = i + 1
Loop
End Sub
Sub get_worksheet(name)
ActiveWorkbook.Worksheets.Add
..etc
end sub
With data like:
In column I, this is a way to get the last item before the empty:
Sub marine()
i = 2
Do Until Cells(i, 9).Value = ""
hu = Cells(i, 9).Value
i = i + 1
Loop
MsgBox hu
End Sub
Ok I googled and found out the problem, error message was due to "This error happens also when a Sub is called the same as variable (i.e. in one Sub you have for loop with iterator "a", whilst another Sub is called "a")."
I changed the name of variable and code works.
Thanks to everyone
This code is producing an "Object not found" error.
Sub Button86_Click()
Dim Y As Integer
Dim i As Integer
Dim LastRow As Long
Y = 2
Worksheets("Abnormal").Activate
With ActiveSheet
LastRow = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
End With
Sheets("Abnormal").Rows(1).Copy Destination:=Sheets("Ab_IT").Rows(1)
For i = 2 To LastRow
If Abnormal.Cells(i, 11).Value = "IT" Then
Sheets("Abnormal").Rows(i).Copy Destination:=Sheets("Ab_IT").Rows(Y)
Y = Y + 1
End If
Next i
Worksheets("Ab_IT").Activate
With ActiveSheet.UsedRange
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Cells(1).Select
End With
Application.CutCopyMode = False
Worksheets("Ab_IT").Columns("A:J").AutoFit
End Sub
** Error line - If Abnormal.Cells(i, 11).Value = "IT" Then
Details - There are two sheets. Abnormal and Ab_IT.
In Abnormal sheet, there is one column(11),which sometimes contain "IT"
I am trying to copy all the rows, which contain IT to another sheet Ab_IT.
But getting an error object not defined.
I don't see the variable 'Abnormal' defined prior to this line:
If Abnormal.Cells(i, 11).Value = "IT" Then
Maybe you meant:
If Sheets("Abnormal").Cells(i, 11).Value = "IT" Then
I want to write the current month based on a referenced cell into the current selection. This is my code but I get the error message: object variable or with block variable not set. I don't know what the problem is - anyone have a clue?
Sub SelectionMonthNames()
Dim Currentrange As Range
For i = 1 To 3
Currentrange = Selection.Address
If i = 1 Then
Currentrange.Formula = "=DATE(YEAR($B$5);MONTH($B$5);DAY($B$5))"
Else
Currentrange.Formula = "=DATE(YEAR($B$5);MONTH($B$5)+" & CStr(i - 1) & ";DAY($B$5))"
End If
Selection.Offset(0, 1).Select
Next i
End Sub
Try
Set Currentrange = Selection.Address
Instead of
Currentrange = Selection.Address
EDIT:
So, final version of your macro should look like this:
Sub SelectionMonthNames()
Dim Currentrange As Range
For i = 1 To 3
Set Currentrange = Selection
If i = 1 Then
Currentrange.Formula = "=DATE(YEAR($B$5),MONTH($B$5),DAY($B$5))"
Else
Currentrange.Formula = "=DATE(YEAR($B$5),MONTH($B$5)+" & CStr(i - 1) &",DAY($B$5))"
End If
Selection.Offset(0, 1).Select
Next i
End Sub