the combination of this sub in a module
Sub hithere3()
Dim Rng As Range
Dim Unique As Boolean
For Each Rng In Worksheets("Sheet8").Range("FS3:FS30") 'for each cell in your B1 to B30 range, sheet1
Unique = True 'we'll assume it's unique
Lastunique = Worksheets("TRADES").Range("C:C").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 3 To Lastunique 'for each cell in the unique ID cache
If Rng.Value = Worksheets("TRADES").Cells(i, 3).Value Then 'we check if it is equal
Unique = False 'if yes, it is not unique
End If
Next
If Unique Then Worksheets("TRADES").Cells(Lastunique + 1, 3) = Rng 'adds if it is unique
Next
End Sub
with the loop check in a worksheet change events
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
works except it only updates when I select one of the cells in FS3:FS33
Can anyone suggest how this can be overcome?
maybe with a workchange change range selection type from below?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range, Dn As Range, n As Long
Dim RngB As Range, RngC As Range
If Target.Column = 2 And Target.Count = 1 And Target.Row > 1 Then
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
Set RngB = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp))
Set RngC = Range(Range("C2"), Range("C" & Rows.Count).End(xlUp))
ray = Array(RngB, RngC)
For n = 0 To 1
For Each Dn In ray(n)
If Not Dn.Address(0, 0) = "C1" And Not Dn.Value = "" Then
.Item(Dn.Value) = Empty
End If
Next Dn
Next n
Range("C2").Resize(.Count) = Application.Transpose(.Keys)
End With
End If
Use either the worksheet Calculate event or the worksheet Change event:
use Calculate if the range contains formulas
use Change if the cells in the range are changed manually
If Intersect(Target, Range("FS3:FS33")) Is Nothing is the culprit. You must change Range("FS3:FS33") to whatever range you want to affect this change.
Private Sub Worksheet_Change(ByVal Target As Range) '<<delete the "Selection" from the name of event
If Intersect(Target, Range("FS3:FS33")) Is Nothing Then
'Do nothing '
Else
Call hithere3
End If
End Sub
Finally figured it out, the following code works :
Private Sub Worksheet_calculate()
If Range("FS3:FS33") Is Nothing Then
'Do nothing'
Else
Call hithere3
End If
End Sub
Related
I'm attempting to have Column K update with last modified date & time of its own row. I got close using the following code, but it modifies everything in the row after it when I only want it to change the Now value in Column K.
Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A:J")) Is Nothing Then
Target.Offset(0, 1) = Now
End If
End Sub
I know I have to change the Taege.Offset to something else, but what would that be to not break code/debug. I considered Target.Column, but I'm unsure of how to write the syntax.
Secondly, I'd like it to ignore row 1 & 2. I thought about changing Range("A:J") to Range("A3:J") but that also break/debugs.
All help is welcomed & appreciated.
You can do it like this:
Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
Set rng = Application.Intersect(Target, Me.Range("A:J"))
If Not rng Is Nothing Then
Application.screenupading = False
For Each c In rng.Cells
c.EntireRow.Columns("K").Value = Now
Next c
End If
End Sub
Maybe try something like this
Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Not Intersect(Target, Range("A:J")) Is Nothing Then
For Each rng In Target.Rows
If rng.Row > 2 Then
Cells(rng.Row, 11).Value = Now
End If
Next rng
End If
End Sub
Perhaps a better solution would be this
Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
If Target.Column < 11 Then
Application.EnableEvents = False
For Each rng In Target.Rows
If rng.Row > 2 Then: Cells(rng.Row, 11).Value = Now
Next rng
Application.EnableEvents = True
End If
End Sub
A solution with no looping needed
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 11 Then ' 11 = K,
Intersect(Range(Cells(3, 11), Cells(WorksheetFunction.Min( _
Target.Rows.CountLarge + Target.Row - 1, Rows.CountLarge), 11)), _
Target.EntireRow).Value = Now
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
StartRow = 21
EndRow = 118
ColNum = 1
For i = StartRow To EndRow
If Cells(i, ColNum).Value = Range("A4").Value Then
Cells(i, ColNum).EntireRow.Hidden = True
Else
Cells(i, ColNum).EntireRow.Hidden = False
End If
Next i
End Sub
The Range I want to dictate when the code is run is D21:D118. It will start out blank and then have data pulled into it
Thank you!
It's quite difficult and error-prone to tell in a Change event handler what the previous cell value was before it was edited. You might consider narrowing the logic so it only runs if a cell in A21:A118 is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range, vA4
'Does Target intersect with our range of interest?
Set rng = Application.Intersect(Target, Me.Range("A21:A118"))
If rng Is Nothing Then Exit Sub 'no change in monitored range
vA4 = Me.Range("A4").Value
For Each c In rng.Cells 'loop over updated cells
c.EntireRow.Hidden = (c.Value = vA4) 'check each updated cell value
Next c
End Sub
Im trying to automatically update current date in cell T when text in cell Q is "won" and a value in cell AM is > 0. I tried the code below and it is working if first the value in cell is > 0 and then you update the text in cell Q BUT if you do it in another way (first update cell Q and secondly the value in cell AM) the date doesn't appear in cell T.
Any idea, what Im I missing?
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [Q:Q]) Is Nothing Then
If UCase(Target) = UCase("won") And Target.Offset(, 22) > 0 Then
Target.Offset(, 2) = Int(Now())
End If
End If
End sub
Your code only checks for changes in Q therefore the update does not take place if you change AM first.
My solution has three parts:
use constants for the columns - in case there are changes to the sheet layout you only have to make adjustments here
worksheet_change: only check if one of the columns is affected then call the according sub - by that the reader of the code immediately understands what is going on here
the main routine that inserts the date if condition is met or removes the date if not (maybe you want to adjust this)
Option explicit
Private Const colStatus As String = "Q"
Private Const colValue As String = "AM"
Private Const colDateWon As String = "S"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c As Range
Set c = Target.Cells(1, 1)
If c.Column = Me.Columns(colStatus).Column Or c.Column = Me.Columns(colValue).Column Then
updateDateWon c.row
End If
End Sub
Private Sub updateDateWon(row As Long)
'--> adjust the name of the sub to your needs
Dim valueToInsert As Variant
With Me
If .Range(colStatus & row) = "won" And .Range(colValue & row) > 0 Then
valueToInsert = Int(Now)
Else
'reset the date in case conditions are not met
valueToInsert = vbNullString
End If
Application.EnableEvents = False 'disable events so that change-event isn't called twice
.Range(colDateWon & row) = valueToInsert
Application.EnableEvents = True
End With
End Sub
A Worksheet Change Applied to Two Non-Adjacent Columns
You need to monitor columns Q and AM for changes.
You need to account for Target being multiple adjacent and non-adjacent cells.
You need to disable events when writing to the worksheet containing this code to not retrigger this event (or trigger any other events).
It is good practice to ensure the re-enabling of events (by using error-handling).
You can combine the cells to be written to (dCell) into a range (drg) and write the stamp in one go.
Int(Now()) or Int(Now) is actually Date.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ClearError
Const sColsAddress As String = "Q:Q,AM:AM"
Const dCol As String = "T"
Const fRow As Long = 2 ' (e.g. 2 for excluding headers in the first row)
Const sCriteria As String = "won"
Dim srg As Range
With Range(sColsAddress)
Set srg = Intersect(.Cells, Rows(fRow).Resize(Rows.Count - fRow + 1))
End With
Dim sirg As Range: Set sirg = Intersect(srg, Target)
If sirg Is Nothing Then Exit Sub
Dim sirg1 As Range: Set sirg1 = Intersect(sirg.EntireRow, srg.Areas(1))
Dim siCol2 As Long: siCol2 = srg.Areas(2).Column
'Dim dirg As Range: Set dirg = sirg1.EntireRow.Columns(dCol) ' not used
Dim siCell1 As Range
Dim siValue2 As Variant
Dim drg As Range
For Each siCell1 In sirg1.Cells
If StrComp(CStr(siCell1.Value), sCriteria, vbTextCompare) = 0 Then
siValue2 = siCell1.EntireRow.Columns(siCol2).Value
If IsNumeric(siValue2) Then
If siValue2 > 0 Then
If drg Is Nothing Then
Set drg = siCell1.EntireRow.Columns(dCol)
Else
Set drg = Union(drg, siCell1.EntireRow.Columns(dCol))
End If
End If
End If
End If
Next siCell1
If Not drg Is Nothing Then
' Prevent retriggering the event when writing to the worksheet.
Application.EnableEvents = False
drg.Value = Now ' only after testing, use 'dDate = Date'
End If
SafeExit:
' Enable events 'at all cost'.
If Not Application.EnableEvents Then Application.EnableEvents = True
Exit Sub
ClearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume SafeExit
End Sub
I'm trying to clear a range of 5 cells when changing another. For example: H5 is changed, J5:J10 is cleared. This works a treat in clearing J5 when H5 is changed.
Private Sub Worksheet_Change(ByVal Target As Range)
If Left(Target.Address(, False), 1) = "H" Then Target.Offset(, 2).ClearContents
End Sub
However this does not clear the 4 cells below. I was wary of using a function to specify the range as I've got multiple rows of data in H. So for example if H24 changes, J24:J29 are cleared, which goes on for about 200 rows...
Any help is appreciated!
The Offset-function returns a range with the same size than the original Range, just at a different place. To increase (or decrease) the size of a range, you can use the Resize-function. So basically, you need to combine both functions.
I don't want to argue with you about how to check for the column, but I think using If Target.Column = 8 Then is much easier.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 8 Then ' Col H
Dim destRange As Range
Set destRange = Target.Offset(0, 2).Resize(5, 1)
Debug.Print destRange.Address
destRange.ClearContents
End If
End Sub
Be aware that Target may contain more than one cell (eg via Cut&Paste), you probably need to handle that.
This should do it.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(, 2), Target.Offset(5, 2)).ClearContents
Application.EnableEvents = True
End Sub
Okay with merged cells offset gets weird and even offsetting the topleft cell of the merged area (Target.MergeArea(1, 1)) will give bad results so we need to create the range ourselves.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
If Target.MergeCells = True Then
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(0, 2), ActiveSheet.Cells(Target.MergeArea(1, 1).Row + 5, Target.MergeArea(1, 1).Offset(0, 2).Column)).ClearContents
Else
If Left(Target.Address(, False), 1) = "H" Then ActiveSheet.Range(Target.Offset(, 2), Target.Offset(5, 2)).ClearContents
End If
Application.EnableEvents = True
End Sub
I hardcoded the 5 into the row change if you need it to be the size of the merged area you will need to get the difference in rows from the top to the bottom of the merged area.
Clear Cells on Any Side of Merged Cells
The colors in the image show which contents will be cleared in column J if a value in a cell in column H is changed (manually or via VBA).
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim doEnableEvents As Boolean
On Error GoTo clearError
Const FirstCellAddress As String = "H2"
Const ColOffset As Long = 2
Dim irg As Range
With Range(FirstCellAddress)
Set irg = Intersect(.Resize(.Worksheet.Rows.Count - .Row + 1), Target)
End With
If Not irg Is Nothing Then
Application.EnableEvents = False
doEnableEvents = True
Dim arg As Range
Dim cel As Range
For Each arg In irg.Areas
For Each cel In arg.Cells
If cel.MergeCells Then
With cel.MergeArea
.Cells(1, 1).Offset(, ColOffset).Resize(.Rows.Count) _
.ClearContents
End With
Else
cel.Offset(, ColOffset).ClearContents
End If
Next cel
Next arg
End If
ProcExit:
If doEnableEvents Then
Application.EnableEvents = True
End If
Exit Sub
clearError:
Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
Resume ProcExit
End Sub
Sub testMultiArea()
Dim rg As Range: Set rg = Range("H2,H7")
rg.Value = 500
End Sub
I want to find row number of first empty cell in column and store that row number in Cell Z1.
I tried with Following macro code but it goes into loop forever.
As soon as it tries to set the value in Cell Z1 it again goes into worksheet_change event again and then again in for loop.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cell In ws.Columns(3).Cells
If IsEmpty(cell) = True Then Range("$Z$1").Value = cell.Row: Exit For
Next cell
End Sub
Please help to resolve this.
Thanks
Maybe this code is of any help
Option Explicit
Function firstEmptyCell(col As Long, Optional ws As Worksheet) As Range
If ws Is Nothing Then
Set ws = ActiveSheet
End If
Dim rg As Range
Set rg = ws.Cells(1, col)
If Len(rg.Value) = 0 Then
Set rg = rg.Offset
Else
If Len(rg.Offset(1).Value) = 0 Then
Set rg = rg.Offset(1)
Else
Set rg = rg.End(xlDown)
Set rg = rg.Offset(1)
End If
End If
Set firstEmptyCell = rg
End Function
And the Event code is
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo EH
If Target.Column <> 12 Then
Exit Sub
End If
Application.EnableEvents = False
Range("Z1").Value = firstEmptyCell(12).Row
EH:
Application.EnableEvents = True
End Sub
Update: Based on the comments regarding the pitfalls of the change event one could change firstEmptyCell slightly and use a UDF only
Function firstEmptyCellA(col As Long, Optional ws As Worksheet) As Long
On Error GoTo EH
If ws Is Nothing Then
Set ws = ActiveSheet
End If
Application.Volatile
Dim rg As Range
Set rg = ws.Cells(1, col)
If Len(rg.Value) = 0 Then
Set rg = rg.Offset
Else
If Len(rg.Offset(1).Value) = 0 Then
Set rg = rg.Offset(1)
Else
Set rg = rg.End(xlDown)
Set rg = rg.Offset(1)
End If
End If
firstEmptyCellA = rg.Row
Exit Function
EH:
firstEmptyCellA = 0
End Function
Tricky Enable Events
This is triggered only when a cell in the 12th column (L) is changed, otherwise there is no need for it. If you have formulas there, then this will not work and you'll have to use the Worksheet_Calculate event.
Row of First Empty Cell in Column
Option Explicit
' Row of First Empty Cell in Column
Private Sub Worksheet_Change(ByVal Target As Range)
Const TargetCell As String = "Z1"
Const TargetColumn As Variant = 12 ' (or "L")
Dim rng As Range
If Intersect(Columns(TargetColumn), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set rng = Columns(TargetColumn).Find(What:="", _
After:=Cells(Rows.Count, TargetColumn), LookIn:=xlValues)
If rng Is Nothing Then
Range(TargetCell).Value = 0 ' Full column. No empty cells.
Else
Range(TargetCell).Value = rng.Row
End If
Application.EnableEvents = True
End Sub
Row of First Empty Cell After Last Non-Empty Cell in Column
Option Explicit
' Row of First Empty Cell After Last Non-Empty Cell in Column
Private Sub Worksheet_Change(ByVal Target As Range)
Const TargetCell As String = "Z1"
Const TargetColumn As Variant = 12 ' (or "L")
Dim rng As Range
If Intersect(Columns(TargetColumn), Target) Is Nothing Then Exit Sub
Application.EnableEvents = False
Set rng = Columns(TargetColumn).Find(What:="*", LookIn:=xlFormulas, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then ' Empty column. No non-empty cells.
Range(TargetCell).Value = 1
Else
If rng.Row = Rows.Count Then ' Last (bottom-most) cell is not empty.
Range(TargetCell).Value = 0
Else
Range(TargetCell) = rng.Offset(1).Row
End If
End If
Application.EnableEvents = True
End Sub
Dont need a loop. Paste this in a module not in a worksheet event unless you want it for every worksheet change.
Sub Macro1()
ActiveSheet.Range("Z1") = ActiveSheet.Columns(3).SpecialCells(xlCellTypeBlanks)(1).Row
End Sub
if you want it after every change then put it in a worksheet as. This code will not run everytime. It will check if Z1 is empty then enter the valu. Then if Z1 is not empty it will check if the target cell is in column C
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Set Rng = ActiveSheet.Columns(3)
If IsEmpty(Range("Z1")) Then
Range("Z1") = Rng.SpecialCells(xlCellTypeBlanks)(1).Row
Else
If Not Intersect(Range("C1:C" & Range("Z1").Value), Target) Is Nothing Then
Range("Z1") = Rng.SpecialCells(xlCellTypeBlanks)(1).Row
End If
End If
End Sub