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
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
I've got a sheet with Data.
I want to calculate the difference between date now and the date which are in cells C3:C10. And the results are stored in cells D3:D10.
That part I got it so far.
But if someone manipulates the values in the result cells then the VBA should recalculate those cells and correct the results.
Private Sub Worksheet_Change(ByVal Target As Range)
For Zeile = 3 To 10
Sheets("Tabelle2").Cells(Zeile, "D") = WorksheetFunction.YearFrac(Sheets("Tabelle2").Cells(Zeile, "C"), Date)
If Sheets("Tabelle2").Cells(Zeile, "C") = 0 Then
Sheets("Tabelle2").Cells(Zeile, "D") = ""
End If
Next Zeile
End Sub
The first thing to do is check if the change has been made in C3:C10, you can use Intersect for that.
Then you should disable events to stop the code triggering itself, use Application.EnableEvents = False for that.
Next loop through Target in case more than one cell has been changed and perform the required actions/calculations.
Finally re-enable events using Application.EnableEvents = True
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim cell As Range
Dim Zeile As Long
Set rng = Intersect(Target, Range("C3:C10"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng.Cells
Zeile = cell.Row
If Cells(Zeile, "C") <> 0 Then
Cells(Zeile, "D") = Application.YearFrac(Cells(Zeile, "C").Value, Date)
Else
Cells(Zeile, "D") = ""
End If
Next cell
Application.EnableEvents = True
End If
End Sub
If you want the code to be triggered if a value is changed in either C3:C10 or D3:D10 change this,
Set rng = Intersect(Target, Range("C3:C10"))
to this.
Set rng = Intersect(Target, Range("C3:D10"))
You can also change the range address there if you want to further rows by changing 10.
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 am a beginner in VBA.
I have a Column "A" can have multiple values, of which 2 are "Impact Assessed" or "Ready for retesting".
Problem Statement - I want to record the dates when cell's value is changed to Impact Assessed and Ready for Retesting in 2 separate columns - Column B and Column C, respectively.
Below is my code -
Private Sub Worksheet_Calculate()
Dim rng As Range
If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("AA:AA"), Target)
If Not rng Is Nothing Then
Select Case (rng.Value)
Case "2 - Impact Assessed": rng.Offset(0, 1).Value = Date
Case "4 - Ready for retesting": rng.Offset(0, 2).Value = Date
End Select
End If
End Sub
I have made the code as versatile as possible. Just change the constants and, if need be, the search criteria in the Criteria variable to suit your worksheet and you can change your sheet as you like without needing to modify the code.
Private Sub Worksheet_Change(ByVal Target As Range)
' 040
Const TriggerClm As String = "A" ' change to suit
Const WriteToClm As String = "B" ' the second one is next to this
Dim Rng As Range ' working range
Dim C As Long ' WriteToClm
Dim Criteria() As String ' selected values from TriggerClm
Dim i As Integer ' index to Criteria()
' don't respond to changes of multiple cells such as Paste or Delete
If Target.CountLarge > 1 Then Exit Sub
' respond to changes in cells from row 2 to
' one cell below the last used row in the trigger column
Set Rng = Range(Cells(2, TriggerClm), _
Cells(Rows.Count, TriggerClm).End(xlUp).Offset(1))
If Not Application.Intersect(Rng, Target) Is Nothing Then
' intentionally all lower case because comparison
' is carried out case insensitive
' First item's date is in WriteToClm
Criteria = Split("impact assessed,ready for retesting", ",")
For i = UBound(Criteria) To 0 Step -1
If StrComp(Target.Value, Criteria(i), vbTextCompare) = 0 Then Exit For
Next i
' i = -1 if no match was found
If i >= 0 Then
C = Columns(WriteToClm).Column + i
Cells(Target.Row, C).Value = Date
End If
End If
End Sub
You can use something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'If Target.CountLarge > 1 Then Exit Sub
Set rng = Application.Intersect(Me.Range("A:A"), Target)
If Not rng Is Nothing Then
For Each c in rng.cells
Select Case LCase(c.Value)
Case "impact assessed": c.Offset(0, 1).Value = Date
Case "ready": c.Offset(0, 2).Value = Date
End Select
Next c
End If
End Sub
FYI = Range(Target.Address) is the same (in this case) as Target - no need to get the address just to turn that back into a range.
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