Is there any way to remove error message(object required message) that pops out from the input box whenever the user presses the cancel button?
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set inp = Selection
inp.Interior.ColorIndex = 37
Set rng = Application.InputBox("Copy to", Type:=8)
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then cell.Clear
Next
End Sub
Not quite sure why you are using the inputbox, you don't even use it in the code.
This should take care of the errors.
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
'to remove 0 values that may be a result of a formula or direct entry.
Set rng = Nothing
Set inp = Selection
inp.Interior.ColorIndex = 37
On Error Resume Next
Set rng = Application.InputBox("Copy to", Type:=8)
On Error GoTo 0
If TypeName(rng) <> "Range" Then
MsgBox "Cancelled...", vbInformation
Exit Sub
Else
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
End If
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then cell.Clear
Next
Application.CutCopyMode = 0
End Sub
That is not a InputBox error. That is your wrong usage. In your code, you immediately set value from InputBox return. That may cause error because of setting empty value("") to an Range object.
So, you need to modify as follow:
Sub WorkingDuoFunctionCode()
Dim rng As Range, inp As Range
Dim inputRange As String
'to remove 0 values that may be a result of a formula or direct entry.
Set inp = Selection
inp.Interior.ColorIndex = 37
inputRange = Application.InputBox("Copy to")
If Not IsEmpty(inputRange) Then
Set rng = Range(inputRange)
rng.Parent.Activate
rng.Select
inp.Copy
Worksheets("Sheet2").Paste Link:=True
For Each cell In Range("A1:CL9935")
If cell.Value = "0" Then
cell.Clear
End If
Next
End If
End Sub
Not tested. Suggestion for you. If it is not work, let me know.
Related
I am trying to write the VBA Code for checking if the formula exists in a range of cells. Below is my query which is somehow not working(The cells with formulas are not turning red). Can anyone please help me out.
Sub Test()
Dim LResponse As Integer
Set rr = Application.InputBox( _
prompt:="Select a range On this worksheet", _
Type:=8)
If rr.HasFormula = TRUE Then
rr.Interior.Color = vbRed
End If
End Sub
Edit: I tried looping too
Sub Test()
Set rr = Application.InputBox( _
prompt:="Select a range On this worksheet", _
Type:=8)
For Each cell In Range(rr)
If cell.HasFormula = TRUE Then
cell.Interior.Color = vbRed
End If
Next
End Sub
From the Range.HasFormula docs:
True if all cells in the range contain formulas; False if none of the cells in the range contains a formula; null otherwise.
Its return value is determined by all the cells having or not having formulas. If only some have formulas, then it is null.
To fix your issue, use a loop over each individual cell:
Dim rng as Range
For Each rng in rr
If rng.HasFormula Then
rng.Interior.Color = vbRed
End If
Next
EDIT: In your loop attempt, drop the Range call:
For Each cell in rr
EDIT 2: You can also use Range.SpecialCells:
On Error Resume Next '<~ an error will occur if there are no formula cells
Dim rng as Range
Set rng = rr.SpecialCells(xlCellTypeFormulas)
On Error GoTo 0
If Not rng Is Nothing Then
rng.Interior.Color = vbRed
End If
I want to check all cells in columns D to O. If the cell is empty, replace it by a hard zero.
I have this code:
Sub replace()
Dim rng As Range, cell As Range
Dim aantalrijen As Long
With Worksheets("Schaduwblad")
aantalrijen = .Range("A1", .Range("A1").End(xlDown)).Cells.Count - 1
Set rng = .Range(.Cells(2, "D"), .Cells(aantalrijen, "O"))
For Each cell In rng
cell = WorksheetFunction.Substitute(cell, "", "0")
Next
End With
End Sub
This code hangs during processing. Only option is to end the routine by pressing Escape.
You don't need to loop through all the cells. Let Excel find the empties with .SpecialCells:
On Error Resume Next
rng.SpecialCells(xlCellTypeBlanks, xlCellTypeConstants).Value = 0
On Error GoTo 0
The error trap is required in case no empty cells are found.
So your whole routine could be replaced with:
Sub replace()
On Error Resume Next
With Worksheets("Schaduwblad")
.Range(.Cells(2, "D"), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, "O")) _
.SpecialCells(xlCellTypeBlanks, xlCellTypeConstants).Value = 0
End With
On Error GoTo 0
End Sub
Further to your comment below, here is a version of the same code, but working on a row-by-row basis. To test this, I built a 227,000 x 15 block of data and then using a random number generator punched 100,000 holes into it, emptying those cells. I then ran the following code, which took 33 seconds to fill those 100,000 holes back in.
Sub replace()
Dim rangesection As Range
On Error Resume Next
With Worksheets("Schaduwblad")
For Each rangesection In .Range(.Cells(2, "D"), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, "O")).Rows
rangesection.SpecialCells(xlCellTypeBlanks, xlCellTypeConstants).Value = 0
Next
End With
On Error GoTo 0
End Sub
I've never used the substitute methode.. I would do this by checking if cell is empty with the IsEmpty() function.
So yo can swap
cell = WorksheetFunction.Substitute(cell, "", "0")
with
If IsEmpty(cell) Then cell.value = 0
Full code:
Sub replace()
Dim rng As Range, cell As Range
Dim aantalrijen As Long
With Application.ThisWorkbook.Worksheets("Schaduwblad")
aantalrijen = .Range("A1", .Range("A1").End(xlDown)).Cells.Count - 1
Set rng = .Range(.Cells(2, "D"), .Cells(aantalrijen, "O"))
For Each cell In rng
If IsEmpty(cell) Then cell.value = 0
Next
End With
End Sub
I am using the following code to let users select the cell they want to edit.
Application.InputBox(Prompt:="Click the cell you want to edit.", Title:="Cell To Edit", Type:=8)
How can I change my code so they can only select one cell at a time?
Is this what you are trying?
Sub Sample()
Dim r As Range
Do
On Error Resume Next
Set r = Application.InputBox(Prompt:="Click the single cell you want to edit.", _
Title:="Cell To Edit", _
Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
If r.Cells.Count = 1 Then
Exit Do
Else
MsgBox "Please select a single cell only"
Set r = Nothing
End If
Loop
'MsgBox r.Address
End Sub
How about:
Sub qwerty()
Dim r As Range
Set r = Range("A1:A2")
While r.Count <> 1
Set r = Application.InputBox(Prompt:="Click the cell you want to edit.", Title:="Cell To Edit", Type:=8)
Wend
End Sub
There is something wrong with the following code. It correctly shows the InputBox when the user enters the values 9 or 10 in range J1:J503, but the InputBox output doesn't get shown in column L as I intended. Why?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vrange As Range, cell As Range
Dim TheAnswer$
Set vrange = Range("J1:J503")
If Intersect(vrange, Target) Is Nothing Then Exit Sub
For Each cell In Intersect(vrange, Target)
If cell.Value = 9 Or cell.Value = 10 Then
Target.Offset(0, 2).Select
TheAnswer = InputBox("Please put comments", "Comments required for option 9 and 10")
End If
Next cell
End Sub
That's because you didn't tell it to display anything in column L.
To do so, you can add this line of code just before End If:
Selection.Value = TheAnswer
Refactoring your code a little bit (inline temp and getting rid of .Selection which no one should ever use, in my opinion):
Dim vrange As Range, cell As Range
Set vrange = Range("J1:J503")
If Intersect(vrange, Target) Is Nothing Then Exit Sub
For Each cell In Intersect(vrange, Target)
If cell.Value = 9 Or cell.Value = 10 Then
With Target.Offset(0, 2)
.Value = InputBox("Please put comments", "Comments required for option 9 and 10")
.Select ' do you really need this? If not, get rid of it
End With
End If
Next cell
I'm creating an excel file with column A to H are mandatory cells.
This excel file will be passing around for input.
So, I would like to highlight the empty cells as a reminder.
I have written the following code...
Sub Highlight_Cell()
Dim Rng As Range
For Each Rng In Range("A2:H20")
If Rng.Value = "" Then
Rng.Interior.ColorIndex = 6 ‘yellow
Else
Rng.Interior.ColorIndex = 0 'blank
End If
Next Rng
MsgBox "Please fill in all mandatory fields highlighted in yellow."
End Sub
However, I would like to set the range from A2 to the last row that contains data within column A to H.
Also, display the message box only when empty cell exist.
Could you please advise how should I amend?
Million Thanks!!!
This is a VBA solution that prevents the user from saving until the desired range is filled (acknowledging Gserg's comment that that the last row is one that has at least one cell entered)
In the second portion you can either add your sheet index directly, Set ws = Sheets(x) for position x, or Set ws = Sheets("YourSheet") for a specific sheet name
The code will only highlight truly blank cells within A to H of this sheet till the last entered cell (using SpecialCells as a shortcut). Any such cells will be selected by the code on exit
Put this code in the ThisWorkbook module (so it fires whenever the user tries to close the file)
Private Sub Workbook_BeforeClose(Cancel As Boolean)
bCheck = False
Call CheckCode
If bCheck Then Cancel = True
End Sub
Put this code in a standard module
Public bCheck As Boolean
Sub CheckCode()
Dim ws As Worksheet
Dim rng1 As Range
Dim rng2 As Range
bCheck = False
'works on sheet 1, change as needed
Set ws = Sheets(1)
Set rng1 = ws.Columns("A:H").Find("*", ws.[a1], xlValues, xlWhole, xlByRows)
If rng1 Is Nothing Then
MsgBox "No Cells in columns A:H on " & ws.Name & " file will now close", vbCritical
Exit Sub
End If
Set rng2 = ws.Range(ws.[a1], ws.Cells(rng1.Row, "H"))
On Error Resume Next
Set rng2 = rng2.SpecialCells(xlBlanks)
On Error GoTo 0
If rng2 Is Nothing Then Exit Sub
bCheck = True
rng2.Interior.Color = vbYellow
MsgBox "Please fill in all mandatory fields on " & ws.Name & " highlighted in yellow", vbCritical, "Save Cancelled!"
Application.Goto rng2.Cells(1)
End Sub