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
Related
I want data in the cells of column J to copy the data in the cells of column G once data is inputted into column G and not before.
However, prior to this replication taking place I would like to be able to manually update the price in the cells of column J.
See the attached photo for clarity.
Could anyone suggest a solution? I know VBA is a possibility, however, my Excel knowledge is not good enough to write code.
Yellow headings represent no formulas and blue represent formulas.
Excel_Worksheet_ TRADE LOG
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("C:C"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, -1).ClearContents
Else
With .Offset(0, -1)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
With Target
If .Count > 1 Then Exit Sub
If Not Intersect(Range("G:G"), .Cells) Is Nothing Then
Application.EnableEvents = False
If IsEmpty(.Value) Then
.Offset(0, 12).ClearContents
Else
With .Offset(0, 12)
.NumberFormat = "dd MMM yyyy"
.Value = Now
End With
End If
Application.EnableEvents = True
End If
End With
End Sub
A Simple Worksheet Change
If values in the column range from G2 to the bottom-most (last) cell of the worksheet, are changed manually or via code, the values of the cells in the corresponding rows in column J will be overwritten with the values from column G.
This solution is automated, you don't run anything.
Sheet Module e.g. Sheet1 (in parentheses in Project Explorer of Visual Basic Editor)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const sCell As String = "G2" ' Source First Cell
Const dCol As Variant = "J" ' Destination Column Id (String or Index)
Dim irg As Range ' Intersect Range
Dim cOffset As Long ' Column Offset
With Range(sCell)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
If irg Is Nothing Then Exit Sub
cOffset = Columns(dCol).Column - .Column
End With
Dim arg As Range ' Current Area of Intersect Range
Dim cel As Range ' Current Cell in Current Area of Intersect Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If Not IsError(cel.Value) Then
cel.Offset(, cOffset).Value = cel.Value
End If
Next cel
Next arg
End Sub
I would like to display a msgbox if the formula fuelled cell in column I:I changes to TRUE after the cell in column D:D is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRange As Range
myRange = Range("D:D")
If Intersect(myRange, Target) Then
If Target.Offset(0, 3).Value = True Then MsgBox "Date Range and Holiday Type Mismatch"
End If
End Sub
This is an exaxmple of the table. Basically i will update column D:D with the holiday type. In column I:I the cell will change to TRUE if the date range is not acceptable. If the cell in column I:I changes to TRUE i want the msg box to display.
A good starting attempt, but several issues, including the need for Set when working with Range objects, and an offset that seems... off.
Here's one approach:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim myRng As Range
Set myRng = Intersect(Target, Me.Columns("D:D"))
If myRng Is Nothing Then Exit Sub
Dim myCell As Range
For Each myCell In myRng
If Me.Cells(myCell.Row, "I").Value = True Then
MsgBox "Date Range and Holiday Type Mismatch"
End If
Next
End Sub
I have to macro
one for changing the text in rang to uppercase and the other one for clear rang content.
This the first one
Private Sub Worksheet_Change(ByVal Target As Range)
If Not (Application.Intersect(Target, Range("B9:B28")) _
Is Nothing) Then
With Target
If Not .HasFormula Then
Application.EnableEvents = False
.Value = UCase(.Value)
Application.EnableEvents = True
End If
End With
End If
End Sub
It work fine and when I enter a value it changes it to uppercase, But when I run this macro to clear range content
Sub clearCellContentsKeepFormatting()
Dim Answer As VbMsgBoxResult
Answer = MsgBox("Are you sure about this?", vbYesNo + vbQuestion, "Clear All Proudcts")
If Answer = vbYes Then
Range("B9", "B28").ClearContents
Range("C9", "C28").ClearContents
Else
Exit Sub
End If
End Sub
I get
Runtime Error 13 type mismatch
And when I press debug button it marks this line
.Value = UCase(.Value)
So, How can I fix that?
It's happening because .Value is an array if the target range has more than one cell, and you cant call UCase on an array.
You could get round this by processing each cell one at a time:
Dim c As Range
With Target
If Not .HasFormula Then
Application.EnableEvents = False
For Each c In Target
c.Value = UCase(c.Value)
Next c
Application.EnableEvents = True
End If
End With
though this will have a performance impact.
Another point is that you appear to be attempting to set the whole of the Target range to upper case, not only the part that overlaps with B9:B28. If you only want B9:B28 to be forced to upper case, you need something like:
Dim rngIntersection As Range
Set rngIntersection = Application.Intersect(Target, Range("B9:B28"))
If Not (rngIntersection Is Nothing) Then
Dim c As Range
With rngIntersection
If Not .HasFormula Then
Application.EnableEvents = False
For Each c In rngIntersection
c.Value = UCase(c.Value)
Next c
Application.EnableEvents = True
End If
End With
End If
My code currently colors values in Range("N2:N86") anytime I insert a value in that range. However, I want to add an additional line of code that colors or highlights the preceding column Range("M2:M86") whenever a value is entered in Range("N2:N86").
So for example, if i put the value of 1 in N2, I want both N2 and M2 to be highlighted red. Thanks
Dim rCell As Range
Dim inRng As Range
Dim rRng As Range
Set myRng = Range("N2:N86")
myRng.Locked = True
If Range("R4") < 0 Then
For Each rCell In myRng
If rCell.Value > 0 Then
If rRng Is Nothing Then
Set rRng = rCell
Else
Set rRng = Application.Union(rRng, rCell)
End If
End If
Next
rRng.Locked = False
rRng.Interior.ColorIndex = 3
End If
I'm not 100% sure on what you are asking for, but here's something that you can test. (Colors rows in both columns upon change in cell value in N column)
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Not Intersect(Range("N2:N86"), Target) Is Nothing Then
Target.Interior.ColorIndex = 36
Target.Offset(, -1).Interior.ColorIndex = 36
End If
Application.EnableEvents = True
End Sub
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.