I want to insert or remove a "X" inside cells inside a certain range ("A1:A19"), by double clicking. The code below is placed on the "Microsoft Excel Objects\ThisWorkbook" in the project macro.
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1:A19")) Is Nothing Then
If Len(Trim(Target)) = 0 Then
Target.Value = "X"
Cancel = True
ElseIf UCase(Trim(Target)) = "X" Then
Target.ClearContents
Cancel = True
End If
End If
End Sub
This code works for non merged cells. However, I have a situation where the cells must be merged ( 2 by 2, in the column), and in this situation I get the following error:
"Run-time error '13'"
Type mismatch
How must be the code modified to prevent this?
try
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1:A19")) Is Nothing Then
If Target.Cells.Count = 1 Then ' handle single cell
If Len(Trim(Target)) = 0 Then
Target.Value = "X"
Cancel = True
ElseIf UCase(Trim(Target)) = "X" Then
Target.ClearContents
Cancel = True
End If
Else ' handle merged
Dim theAddress As String
theAddress = Split(Target.Address, ":")(0) & ":" & Split(Target.Address, ":")(0)
If Len(Trim(Range(theAddress))) = 0 Then
Target.Value = "X"
Cancel = True
ElseIf UCase(Trim(Range(theAddress))) = "X" Then
Target.ClearContents
Cancel = True
End If
End If
End If
End Sub
When your cells are merged, target is returning a range of multiple cells and it is trying to put a value into cells it can't put values into. Try this:
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim myRange As Range
Set myRange = Target.Cells(1, 1)
If Not Intersect(myRange, Range("A1:A19")) Is Nothing Then
If Len(Trim(myRange)) = 0 Then
myRange.Value = "X"
Cancel = True
ElseIf UCase(Trim(myRange)) = "X" Then
Target.ClearContents
Cancel = True
End If
End If
End Sub
It returns a range reference as being the top left cell in your merged range and allows you to enter values based on that.
Related
The following code will update cells to 1-5 based on doubleclicks on the cell.
I'm looking to limit this to a few columns in the spreadsheet (e.g. if I doubleclick on A2, nothing should happen).
Clearly the .Columns("B:C") is not in the right spot.
Private Sub Worksheet.Columns("B:C")_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
If Target.Value < 5 Then
Target.Value = Target.Value + 1
Else
Target.Value = 5
End If
End Sub
As mentioned by Scott Craner in the comments, the proper way to handle this is to test if the Target range intersects the columns.
I would also recommend setting Cancel = True. This prevents the cell from going into edit mode.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Columns("B:C"), Target) Is Nothing Then
If Target.Value < 5 Then
Target.Value = Target.Value + 1
Else
Target.Value = 5
End If
Cancel = True
End If
End Sub
A Worksheet Before Double-Click: Increment Cell Value
Adjust the values in the event procedure.
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Reference (set) the range (columns).
Dim srg As Range: Set srg = SetColumnsUR(Me, "B2:C2,E2,G2:H2")
' Check if the double-clicked cell ('Target') doesn't intersect.
If Intersect(srg, Target) Is Nothing Then Exit Sub
' Write the integer according to the logic.
Target.Value = MyIntegerLogic(Target.Value, 1, 5)
' Suppress the default behavior of double-clicking a cell.
Cancel = True
End Sub
Function SetColumnsUR( _
ByVal ws As Worksheet, _
ByVal FirstRowAddress As String) _
As Range
With ws.Range(FirstRowAddress)
With .Areas(1).Resize(ws.Rows.Count - .Row + 1)
Set SetColumnsUR = Intersect(.Cells, ws.UsedRange)
End With
If .Areas.Count = 1 Then Exit Function
Set SetColumnsUR = Intersect(SetColumnsUR.EntireRow, .EntireColumn)
End With
End Function
Function MyIntegerLogic( _
ByVal Value As Variant, _
ByVal MinInteger As Long, _
ByVal MaxInteger As Long) _
As Long
Dim Number As Long: Number = MinInteger - 1
If VarType(Value) = vbDouble Then ' is a number
If Int(Value) = Value Then ' is a whole number (integer)
Select Case Value
Case MinInteger To MaxInteger - 1: Number = Value + 1 ' 1.)
Case MaxInteger: Number = MaxInteger ' 2.)
Case Else ' covered below
End Select
End If
End If
If Number = MinInteger - 1 Then Number = MinInteger ' 3.) all other cases
MyIntegerLogic = Number
End Function
I am trying to use VBA so that I can input a value in cell B7 in sheet2 and then it would automatically populate in C7 in sheet3 and also work vice versa. I tried the code below and couldn't get it to work, any suggestions? Also would the code be the same for a string of a number?
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo eh
If Not Intersect(Target, ThisWorkbook.Sheets("sheet 2").Range("B7")) Is Nothing Then
Application.EnableEvents = False
ThisWorkbook.Sheets("sheet 3").Range("C" & Target.Row - 0).Value = Target.Value
eh:
Application.EnableEvents = True
If Err <> 0 Then MsgBox Err & " " & Err.Description, , "Error in Worksheet_Change event, sheet 2"
End If
End Sub
A Workbook SheetChange: Same Value in Cells of Worksheets
Note that the code needs to be copied to the ThisWorkbook module.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim wsNames As Variant: wsNames = VBA.Array("sheet 2", "sheet 3")
Dim CellAddresses As Variant: CellAddresses = VBA.Array("B7", "C7")
Dim iCell As Range
Dim n As Long
For n = 0 To UBound(wsNames)
If StrComp(Sh.Name, wsNames(n), vbTextCompare) = 0 Then
Set iCell = Intersect(Sh.Range(CellAddresses(n)), Target)
If Not iCell Is Nothing Then
Application.EnableEvents = False
Me.Worksheets(wsNames(1 - n Mod 2)) _
.Range(CellAddresses(1 - n Mod 2)).Value = iCell.Value
Application.EnableEvents = True
End If
Exit For
End If
Next n
End Sub
I am using below codes as the following:
Code(1)# Worksheet_SelectionChange Insert Date by using Date Picker(calendar) on sheet "North"
Column M.
Code(2) # Worksheet_Change of sheet North to Log changes of any cells and put in sheet("Log").
Code(3) in a separate module "Calendar" to initiate calendar
the codes works except in one condition
Target cells not triggered by event Worksheet_Change
to produce issue use calendar to enter any value but not click outside Column M then delete these values again , then switch to sheet "Log" you will notice that there are no entries for deleted values at all.
As always: any help will be appreciated.
(Link for the real file found in first comment)
Option Explicit
Option Compare Text
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If Not Intersect(Target, Range("M3:M100")) Is Nothing Then
Call Basic_Calendar
Else
boolDate = False 'make it false to trigger the previous behavior in Worksheet_Change event
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range) 'Log Changes of Current Sheet and put in Sheet("Log")
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue 'the array to keep Target values (before UnDo)
Dim SH As Worksheet: Set SH = Sheets("Log")
Dim UN As String: UN = Application.UserName
If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub 'not doing anything if a cell in AK:XFD is changed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target.Cells.Count > 1 Then
TgValue = ExtractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'Put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'Avoide trigger the change event after UnDo
If boolDate Then '____________________________________________________________
Dim prevTarget
prevTarget = Target.value 'memorize the target value
Target.value = PrevVal 'change the target value to the one before changing
RangeValues = ExtractData(Target) 'extract data exactly as before
Target.value = prevTarget 'set the last date
Else '____________________________________________________________
Application.Undo
RangeValues = ExtractData(Target) 'Define RangeValue
PutDataBack TgValue, ActiveSheet 'Put back the changed data
End If
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
columnHeader = Cells(1, Range(RangeValues(r)(1)).Column).value
rowHeader = Range("B" & Range(RangeValues(r)(1)).Row).value
Sheets("Log").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
End If
Next r
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub PutDataBack(arr, SH As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
SH.Range(El(1)).value = El(0)
Next
End Sub
Function ExtractData(Rng As Range) As Variant
Dim a As Range, arr, Count As Long, i As Long
ReDim arr(Rng.Cells.Count - 1)
For Each a In Rng.Areas 'creating a jagged array containing the values and the cells address
For i = 1 To a.Cells.Count
arr(Count) = Array(a.Cells(i).value, a.Cells(i).Address(0, 0)): Count = Count + 1
Next
Next
ExtractData = arr
End Function
' in a separate module "Calendar" to initiate calendar
Option Explicit
Option Compare Text
Public PrevVal As Variant, boolDate As Boolean
Sub Basic_Calendar()
Dim datevariable As Variant
datevariable = CalendarForm.GetDate
If datevariable <> 0 Then
PrevVal = Selection.value: boolDate = True
Selection.value = datevariable
End If
End Sub
In order to make the solution allowing multiple cells entry from the Callendar, but also allowing multiple deletions, please adapt it in the next way:
Use this modified code in the module where Basic_Calendar Sub exists:
Option Explicit
Option Compare Text
Public PrevVal(), boolDate As Boolean
Sub Basic_Calendar()
Dim datevariable As Variant
datevariable = CalendarForm.GetDate
If datevariable <> 0 Then
PrevVal = Selection.value: boolDate = True
Selection.value = datevariable
Else
Erase PrevVal 'to identify the case of deletion
End If
End Sub
Edited:
If your installation/version is not deal with directly loading the array, please use the next version, which do it by iteration:
Sub Basic_Calendar()
Dim datevariable As Variant
datevariable = CalendarForm.GetDate
If datevariable <> 0 Then
Dim i As Long
ReDim PrevVal(1 To Selection.Rows.Count, 1 To 1)
For i = 1 To Selection.Rows.Count
PrevVal(i, 1) = Selection.Cells(i).value
Next i
boolDate = True
Selection.value = datevariable
Else
Erase PrevVal 'to identify the case of deletion
End If
End Sub
Adapt this part of the Worksheet_Change event code in the next way:
If Target.Cells.Count > 1 Then
If Not CBool(Not Not PrevVal) Then boolDate = False 'the new line checking if the multiple rows array is empty (or not)
TgValue = ExtractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'Put the target range in an array (or as a string for a single cell)
boolOne = True
End If
The logic of the modification works as following:
a. When the Calendar form is called and it returns a Date, in a multi rows range, the delivered datevariable is dropped in the selected cells, and their previous value are loaded in PrevVal() array;
b. A change in Column "M:M" triggers the event and in case of PrevVal() not empty, it acts as usually for inserting Data (using the PrevVal() array elements instead of UnDo, which does not work for data added by code). In case of an empty array, it makes boolDate = False, switching the code to the clasic variant (able to use UnDo, because deletion has been done by the user)...
No need to check the code on another PC. It was a matter of solution logic starting from a wrong assumption and it cannot work differently than on your laptop.
I have two codes depend on application events to run.
Code (1) change color of column_A If FilterMode is True on any column of ActiveSheet.
Code (2) Log changes of any cells in ActiveSheet and put in another sheet("Log").
Error raised if : Filtermode = False and any cells changed by fill handle (the small square in the lower-right corner of the selected cell) ,
I got this error
Method 'Undo' of object '_Application' failed
on this line Application.Undo on Code (2).
I tried to use to disable and enable events with code (1) with no luck.
any help will be appreciated.
Option Compare Text
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
'Code (1) change color of column_A If FilterMode is True on any column of active sheet.
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(196, 240, 255)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End Sub
' Code (2) Log Changes of Current Sheet and put in Sheet("Log")
Private Sub Worksheet_Change(ByVal Target As Range)
Dim RangeValues As Variant, r As Long, boolOne As Boolean, TgValue
Dim sh As Worksheet: Set sh = Sheets("Log")
Dim UN As String: UN = Environ$("username")
If Not Intersect(Target, Range("AK:XFD")) Is Nothing Then Exit Sub 'not doing anything if a cell in "AK:XFD" is changed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
If Target.Cells.count > 1 Then
TgValue = extractData(Target)
Else
TgValue = Array(Array(Target.value, Target.Address(0, 0))) 'put the target range in an array (or as a string for a single cell)
boolOne = True
End If
Application.EnableEvents = False 'Avoide trigger the change event after UnDo
Application.Undo
RangeValues = extractData(Target) 'Define RangeValue
putDataBack TgValue, ActiveSheet 'Reinsert changed data
If boolOne Then Target.Offset(1).Select
Application.EnableEvents = True
Dim columnHeader As String, rowHeader As String
For r = 0 To UBound(RangeValues)
If RangeValues(r)(0) <> TgValue(r)(0) Then
columnHeader = Cells(1, Range(RangeValues(r)(1)).Column).value
rowHeader = Range("B" & Range(RangeValues(r)(1)).Row).value
Sheets("Log").Range("A" & Rows.count).End(xlUp).Offset(1, 0).Resize(1, 6).value = _
Array(UN, Now, rowHeader, columnHeader, TgValue(r)(0), RangeValues(r)(0))
'Array("User Name", "Date,Time", "Work Order", "Column Label", "New Value", "Old Value")
Range(RangeValues(r)(1)).EntireRow.AutoFit
If Range(RangeValues(r)(1)).RowHeight < 53 Then
Range(RangeValues(r)(1)).RowHeight = 53
End If
End If
Next r
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub putDataBack(arr, sh As Worksheet)
Dim i As Long, arrInt, El
For Each El In arr
sh.Range(El(1)).value = El(0)
Next
End Sub
Function extractData(rng As Range) As Variant
Dim a As Range, arr, count As Long, i As Long
ReDim arr(rng.Cells.count - 1)
For Each a In rng.Areas 'creating a jagged array containing the values and the cells address
For i = 1 To a.Cells.count
arr(count) = Array(a.Cells(i).value, a.Cells(i).Address(0, 0)): count = count + 1
Next
Next
extractData = arr
End Function
I figured out the issue, although the error rising with code (2) Worksheet_Change event ,
But actually SelectionChange event on code(1) is the real problem.
Apparently, when I drag down, it is sort of like selecting cells individually and all of them at the same time.
To solve this issue, a condition must be added to event SelectionChange to count the target cells:
If Target.Cells.CountLarge = 1 then
So I just modified the code to look like this in the SelectionChange part and it now works perfectly.
'Code (1)
Private Sub worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Cells.CountLarge = 1 Then
Dim Column_A As Range
Set Column_A = ActiveSheet.Range("A3", ActiveSheet.Range("A" & ActiveSheet.Rows.count).End(xlUp))
If ActiveSheet.FilterMode = True Then
Column_A.Interior.Color = RGB(255, 0, 0)
Else 'FilterMode = False
Column_A.Interior.Color = RGB(255, 255, 255)
End If
End If
End Sub
In the meantime, I learned that Calculate event would be best choice to trapping a change to a filtered list as described on this link
https://www.experts-exchange.com/articles/2773/Trapping-a-change-to-a-filtered-list-with-VBA.html
I have a column named "time" in my excel sheet. I want to write a code such that whenever user performs an entry in time column, if it is a whole number, it should accept, but if it is not a pop up should appear saying "only numbers allowed". Also, the validation should be dynamic i.e. should automatically validate next row if users enters a new entry
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Column = Range("Meeting Time").Column Then
If Not (IsNumeric(Target.Value)) Then
MsgBox "only numbers allowed"
Target.Value = ""
Target.Select
End If
End If
End Sub
You could try:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'1. Check if the column that affected is B (change to the column you want)
'2. Check if changed field is one (used to avoid errors if user change more than one cells at the same time)
If Not Intersect(Target, Columns("B:B")) Is Nothing And Target.Count = 1 Then
'Check if target is numeric
If Not IsNumeric(Target.Value) Then
Call Clear(Target)
End If
'Check if target.offset(1,0) is numeric
If Not IsNumeric(Target.Offset(1, 0).Value) Then
Call Clear(Target.Offset(1, 0))
End If
End If
End Sub
Sub Clear(ByVal rng As Range)
'Disable events in order to prevent code to re trigger when clear cell
Application.EnableEvents = False
rng.Value = ""
'Enable events
Application.EnableEvents = True
End Sub
EDITED VERSION:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'1. Check if the column that affected is B (change to the column you want)
'2. Check if changed field is one (used to avoid errors if user change more than one cells at the same time)
If Not Intersect(Target, Columns("B:B")) Is Nothing And Target.Count = 1 Then
'Check if target is numeric
If Not IsNumeric(Target.Value) Then
Call Clear(Target)
ElseIf Target.Value > 160 Or (Target.Value = Int(Target.Value) = False) Then
Call Clear(Target)
End If
'Check if target.offset(1,0) is numeric
If Not IsNumeric(Target.Offset(1, 0).Value) Then
Call Clear(Target.Offset(1, 0))
ElseIf Target.Offset(1, 0).Value > 160 Or (Target.Offset(1, 0).Value = Int(Target.Offset(1, 0).Value) = False) Then
Call Clear(Target)
End If
End If
End Sub
Sub Clear(ByVal rng As Range)
'Disable events in order to prevent code to re trigger when clear cell
Application.EnableEvents = False
rng.Value = ""
'Enable events
Application.EnableEvents = True
End Sub
first you can create a range name for column you want your "time" and you can use the sample codes below.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Column = Range("time").Column Then
If Not (IsNumeric(Target.Value)) Then
MsgBox "only numbers allowed"
Target.Value = ""
Target.Select
End If
End If
End Sub