I need a simple code which will copy contents of adjacent left cell to double clicked cell. This is to help me in making entries as in attached image.
If I click c2 it should copy 3 from b2 and paste it in c2, and it should do it for c2: c100
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws1 As Worksheet: Set ws1 = wb.Worksheets("sheet1")
With ws1
If Not Intersect(Target, Range("b2:b100")) Is Nothing Then
Cancel = True
If Application.CountIf(Sheets(ws1).Range("b2:b100"), Target.Value) = 0 Then
Cells(Target.Row, 3).Value = Target.Value
End If
End If
End With
End Sub
You can do something like this - note in the worksheet code module, you can use Me to refer to the worksheet.
Technically you don't need to qualify the Range(), since in a worksheet module it defaults to that sheet, but it's good practice to always qualify where you can.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Me.Range("C2:C100")) Is Nothing Then
Cancel = True
with Target.Offset(0, -1)
If Len(.Value) > 0 Then Target.Value = .Value
End With
End If
End Sub
This is a simple code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Cells.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("C2:C100")) Is Nothing Then
Cancel = True
Target.Value = Target.Offset(, -1).Value
End If
End Sub
Related
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rg As Range
Set rg = Intersect(Target, Range("A1:J10"))
If Not rg Is Nothing And Range("V7") = "YES" Then
[RowNo] = ActiveCell.Row
[ColNo] = ActiveCell.Column
End If
End Sub
…
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("V7")) Is Nothing Then
If Target = "NO" Then [AK1:AL1] = 0
End If
End Sub
The above SelectionChange does not work when the sheet is in protect mode. Is there any way to correct this. In protect mode it hangs up on the line that says [RowNo] = ActiveCell.Row. This works correctly when sheet is unprotected.
Like this:
'...
Me.Unprotect 'in a sheet module Me=the sheet
[RowNo] = ActiveCell.Row
[ColNo] = ActiveCell.Column
Me.Protect
'...
Please help me with my macro below it doesn't work correctly when I changed value in activecell.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim KeyCells As Range
kolumna = ActiveCell.Column
wiersz = ActiveCell.Row
komorka = Cells(wiersz, kolumna).Address
Set KeyCells = Range(komorka)
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Target.Offset(0, 1) = Target * 12
End If
Application.EnableEvents = True
End Sub
but when I such code as below it works but it works when I change value in cell: $D$3
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim KeyCells As Range
Set KeyCells = Range("$D$3")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
Target.Offset(0, 1) = Target * 12
End If
Application.EnableEvents = True
End Sub
so the problem with my code is here:
komorka = Cells(wiersz, kolumna).Address
Thanks a lot for your help
Move After Return
Application.MoveAfterReturn
It will not work if MoveAfterReturn is set to True, because when you change a value the cursor moves to the next cell which becomes the ActiveCell so they never intersect (Correction: it will work anyway if you're in column A and use the Left arrow to confirm the entry or in A1 use the Up arrow, etc.).
It could work if you set MoveAfterReturn to False, so I wrote the procedure to toggle it. Add a Button or a CommandButton and use it to enable or disable it when necessary.
Note that you have to confirm the cell entry with Enter. The arrows will not do.
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Application.MoveAfterReturn Then
If Not Application.Intersect(ActiveCell, Target) Is Nothing Then
Dim cValue As Variant: cValue = Target.Value
If IsNumeric(cValue) Then
Target.Offset(0, 1).Value = CDbl(cValue) * 12
End If
End If
End If
End Sub
Standard Module e.g. Module1
Option Explicit
Sub toggleMAR()
With Application
If .MoveAfterReturn Then
.MoveAfterReturn = False
Else
.MoveAfterReturn = True
End If
End With
End Sub
The below code copies cell data (range F1:H19), on clicking, and pastes them to the last row of a different worksheet of the same workbook.
When I click on merged cells nothing happens. Like when cells are empty.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("f1:h19")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Cancel = True
Dim Lastrow As Long
Lastrow = Sheets("sheet1").Cells(Rows.Count, "C").End(xlUp).Row + 1
Target.Copy Sheets("sheet1").Cells(Lastrow, 3)
End If
End Sub
Nothing is happening, because if Target is a merged cell, then Target.Cells.Count is greater than 1.
I would change your logic using Range.MergeCells to determine if a merged cell was clicked:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Me.Range("f1:h19")) Is Nothing Then Exit Sub
If Not Target.MergeCells Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Else
If IsEmpty(Target.Cells(1, 1)) Then Exit Sub
End If
Cancel = True
Dim Lastrow As Long
Lastrow = Sheets("sheet1").Cells(Rows.Count, "C").End(xlUp).Row + 1
Target.Cells(1, 1).Copy Sheets("sheet1").Cells(Lastrow, 3)
End Sub
I have an Excel spreadsheet where I want to protect cells in column I if the respective cell of column H <> "yes".
I found a code but it will protect all the cells of column I.
Option explicit
Sub unprotected
Me.unprotect password:= "abc"
End sub
Sub protect
Me.protect userinterfaceonly:= true ,password:= "abc"
End sub
Private Sub Worksheet_change(ByVal Target As Range)
Dim Crow as Long
Call Unprotected
xrow = Target.Row
If not (intersect(Target, range("H3:H1000")) is nothing then
Cells(xrow, "I").locked = (Ucase(trim(cells(xrow, "H").value))<>"yes")
End if
Call protect
End sub
Try this:
Option Explicit
Const PW As String = "abc" '<< use a constant for fixed/shared values
Private Sub Worksheet_change(ByVal Target As Range)
Dim rng As Range, c As Range
'find changed cells in range of interest
Set rng = Application.Intersect(Target, Me.Range("H3:H1000"))
If Not rng Is Nothing Then
UnprotectMe
'process each cell
For Each c In rng.Cells
Me.Cells.Cells(c.Row, "I").Locked = _
(UCase(Trim(Me.Cells(c.Row, "H").Value)) <> "YES")
Next c
ProtectMe
End If
End Sub
Sub UnprotectMe()
Me.Unprotect Password:=PW
End Sub
Sub ProtectMe()
Me.protect userinterfaceonly:=True, Password:=PW
End Sub
The purpose of this code is to update the date in a cell as a certain cell's contents are changed.
Since this was originally coded inside a sub, I now need to expand this code to a range of multiple cells. Ie. At this moment, the code only takes cell D4 and updates cell L4, I want to be able to drag this function down so it can reach a multiple range of cells; take D5 and update L5 etc.
Here's my code as the sub:
Dim oldValue
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target.Worksheet.Range("D4").Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("D4")) Is Nothing Then
If oldValue <> Target.Worksheet.Range("D4").Value Then
Target.Worksheet.Range("L4").Value = Date
End If
End If
End Sub
The problem here, is that I don't know how to properly expand my code to match a further selection of cells. Here's my attempt:
Dim oldValue
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Target.Worksheet.Range("D4", "D21").Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Target.Worksheet.Range("D4", "D21")) Is Nothing Then
If oldValue <> Target.Worksheet.Range("D4", "D21").Value Then
Target.Worksheet.Range("L4", "L21").Value = Date
End If
End If
End Sub
EDIT: The sub I have written only applies to one cell, I am trying to work out a way to have it spread out to a certain selection of cells. Ie. D4:D12 which updates the date in L4:L12 accordingly.
If anyone could help me, that would be greatly appreciated.
Try the following code:
Dim oldValue()
Public Sub Worksheet_SelectionChange(ByVal Target As Range)
oldValue = Me.Range("D4:D12").Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("D4:D12")) Is Nothing Then
Application.EnableEvents = False
Dim c As Range
For Each c In Intersect(Target, Me.Range("D4:D12"))
'Check value against what is stored in "oldValue" (row 4 is in position 1, row 5 in position 2, etc)
If oldValue(c.Row - 3, 1) <> c.Value Then
'Update value in column L (8 columns to the right of column D)
c.Offset(0, 8).Value = Date 'or possibly "= Now()" if you need the time of day that the cell was updated
End If
Next
Application.EnableEvents = True
End If
End Sub
Set up a hidden sheet to hold the old values.
Sub SetupMirrorValues()
With Worksheets.Add
.Name = "MirrorValues"
.visibilty = xlSheetVeryHidden
.Range("D4:D10,D12,D14:D20") = Worksheets("Sheet1").Range("D4:D10,D12,D14:D20")
End With
End Sub
In the Worksheet_Change event handler, you would check the Target cells that intersect with the range you want to monitor. If there are differences then you update the timestamp and the cell on the hidden sheet that corresponds to the changed cell.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Application.ScreenUpdating = False
Dim cell As Range, DRange As Range
Set DRange = Range("D4:D10,D12,D14:D20")
If Not Intersect(DRange, Target) Is Nothing Then
For Each cell In Intersect(DRange, Target)
If cell.Value <> Worksheets("MirrorValues").Range(cell.Address) Then
cell.EntireRow.Cells(1, "L").Value = Now
Worksheets("MirrorValues").Range(cell.Address) = cell.Value
End If
Next
End If
Application.EnableEvents = True
Application.ScreenUpdating = False
End Sub