I picked up this code to select and change the interior color (green) of the EntireRow when the AtiveCell is behind the 6 Row.
I need to select and change the interior color (Color = 9359529) of the column "I" and "J" of the Row where is the ActiveCell. Is similar to this code but do not need the entire row, just the columns I and J.
Dim lTarget As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row >= 6 Then
If Not lTarget Is Nothing Then
lTarget.EntireRow.Interior.ColorIndex = 0
End If
Target.EntireRow.Interior.Color = 9359529
Set lTarget = Target
End If
End Sub
Using just your example and what I think you're asking this is the simplest way to do what I think you're asking.
You either have just one row in the selection - or you just want the first row changed
This can be changed to use a Range object - but this is easy to understand
Dim lTarget As Range
Const TargetCol1 As Integer = 9
Const TargetCol2 As Integer = 10
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Row >= 6 Then
If Not lTarget Is Nothing Then
lTarget.EntireRow.Interior.ColorIndex = 0
End If
Cells(Target.Row, TargetCol1).Interior.Color = 9359529
Cells(Target.Row, TargetCol2).Interior.Color = 9359529
Set lTarget = Target
End If
End Sub
A Worksheet SelectionChange
Many thanks to Tragamor for pointing out the many flaws of my previous attempts.
Option Explicit
Private lTarget As Range
Private FirstPassed As Boolean
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const FirstRow As Long = 6
Const Cols As String = "I:J"
Const iColor As Long = 9359529
Dim rrg As Range
Set rrg = Rows(FirstRow).Resize(Rows.Count - FirstRow + 1)
Dim irg As Range: Set irg = Intersect(rrg, Target)
If Not irg Is Nothing Then Set irg = Intersect(irg.EntireRow, Columns(Cols))
If FirstPassed Then
If irg Is Nothing Then
If Not lTarget Is Nothing Then
lTarget.Interior.ColorIndex = xlNone
Set lTarget = Nothing
End If
Else
If Not lTarget Is Nothing Then
lTarget.Interior.ColorIndex = xlNone
End If
irg.Interior.Color = iColor
Set lTarget = irg
End If
Else
rrg.Columns(Cols).Interior.ColorIndex = xlNone
If Not irg Is Nothing Then
irg.Interior.Color = iColor
Set lTarget = irg
End If
FirstPassed = True
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
I've read through a bunch of similar questions, but I'm honestly not quite understanding the solution. I've changed the code, and essentially seem to have broken it even more.
Expectation: When the data in the E column is changed, the L and M columns will erase themselves. Additionally, if the F column = "DFW" then it will copy/paste the row to the DFW sheet, and then delete and move up the original row from Sheet1.
Current Result: Nothing happening. Before I added the If Nots (which were suggested in previous posts), I would get the functions to work once, but it would have a weird hangtime but work once. After that, I'd have to restart the spreadsheet to get everything to function again.
Bonus: If there is also a way to auto sort based on column N (oldest to newest) and then sub sort based on column A (A to Z). Essentially organize by date, and then those entries organized alphabetically.
Thanks in advance for any help!
Sub Worksheet_Change(ByVal Target As Range)
Dim tbl As ListObject
Dim i As Long
' Exit if more than one cell updated
' If Target.CountLarge > 1 Then Exit Sub
' Check to see if row > 1 and value is "Yes"
' If (Target.Row > 2) And (Target.Value = "DFW") Then
If Not Intersect(Target, Range("F:F")) Is Nothing Then
If Target.Value = "DFW" Then
' Set tbl to new table
Set tbl = Sheets("DFW").ListObjects("Tasks7835")
' Add row
tbl.ListRows.Add , 1
' set i to rowcount of table
i = tbl.ListRows.Count
' copy values
tbl.DataBodyRange(i, 1).Resize(1, 20).Value = Range("A" & Target.Row).Resize(1, 20).Value
Application.EnableEvents = False
' Delete old row
Target.EntireRow.Delete Shift:=xlUp
Application.EnableEvents = True
Exit Sub
End If
' If Target.Cells.Count > 1 Then Exit Sub
' If Intersect(Target, Range("E:E")) Is Nothing Then Exit Sub
If Not Intersect(Target, Range("E:E")) Is Nothing Then
Application.EnableEvents = False
If Target = vbNullString Then
Target.Offset(0, 7) = vbNullString
Target.Offset(0, 8) = vbNullString
Else
Target.Offset(0, 7) = ""
Target.Offset(0, 8) = ""
End If
On Error GoTo 0
End Sub
Try this code:
Option Explicit
Sub Worksheet_Change(ByVal Target As Range)
Dim TCELL As Range
On Error GoTo out
Application.EnableEvents = False
Set TCELL = Intersect(Target, Me.Columns("F"))
If Not TCELL Is Nothing Then
Set TCELL = TCELL(1) ' get only first cell from Target
If UCase(TCELL) = "DFW" Then
ThisWorkbook.Sheets("DFW").ListObjects("Tasks7835") _
.ListRows.Add(, True).Range.Resize(1, 20).Value = _
Me.Range("A" & TCELL.Row).Resize(1, 20).Value
TCELL.EntireRow.Delete
End If
Else
Set TCELL = Intersect(Target, Me.Columns("E"))
If Not TCELL Is Nothing Then
TCELL(1).Offset(0, 7).Resize(, 2) = vbNullString
End If
End If
out:
Application.EnableEvents = True
End Sub
The original code was almost workable. It was missing two End If. Also, Application.EnableEvents = True was omitted from the second part of the procedure. I also removed some redundant commands such as On Error GoTo 0, Target.Offset(0, 7) = "", i = tbl.ListRows.Count. In addition, I introduced a TCELL variable containing one cell (Target can contain multiple cells and in this case throw an error when executing If Target.Value = ... Then)
A Worksheet Change: Backup Before Delete
Option Explicit
Sub Worksheet_Change(ByVal Target As Range)
Const FirstRow As Long = 2
Dim srg As Range
Dim irg As Range
Set srg = Me.Columns("E").Resize(Me.Rows.Count - FirstRow + 1)
Set irg = Intersect(srg, Target)
If Not irg Is Nothing Then
Application.EnableEvents = False
Intersect(irg.EntireRow, Me.Columns("L:M")).ClearContents
Application.EnableEvents = True
Set irg = Nothing
End If
Set srg = Me.Columns("F").Resize(Me.Rows.Count - FirstRow + 1)
Set irg = Intersect(srg, Target)
If Not irg Is Nothing Then
Dim tbl As ListObject
Set tbl = Me.Parent.Worksheets("DFW").ListObjects("Tasks7835")
Dim drg As Range
Dim iCell As Range
Dim lr As ListRow
For Each iCell In irg.Cells
If CStr(iCell.Value) = "DFW" Then
Set lr = tbl.ListRows.Add(, True)
lr.Range.Resize(, 20).Value = iCell.EntireRow.Resize(, 20).Value
If drg Is Nothing Then
Set drg = iCell
Else
Set drg = Union(drg, iCell)
End If
End If
Next iCell
If Not drg Is Nothing Then
Application.EnableEvents = False
drg.EntireRow.Delete xlShiftUp
Application.EnableEvents = True
End If
End If
End Sub
I want to fill the cells with Character Abbreviation, according to the entering number in that cell.
For example I created the following image Where the Column L should be filled with DM, AG, IW, WSW, CW. For this purpose, I used numeric values from 1 to 5 (DM=1, AG=2, IW=3, WSW=4, CW=5). I already
For this, I already entered those values (AR6:AW17) as following in the same sheet.
Tried
I used the following code :
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Range("L:L")) Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Dim foundVal As Range
Set foundVal = Range("AR5:AV5").Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not foundVal Is Nothing Then
Target = foundVal.Offset(1, 0)
End If
Application.ScreenUpdating = True
End Sub
Problem
My question is how can I extend this to put the values to
Column L as AR6:AV6
Column M as AR7:AW7
Column P as AR8:AV8
Column Q as AR14:AU14
Column T as AR15:AV15
Column W as AR17:AU17
Updated
The column Q, T, W are added for more consideration please.
and so on, please?
Resize and Offset in Worksheet Change
Adjust the values in the constants section.
The Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const ColRangesList As String = "L,M,N,P"
Const RowRangesList As String = "AR5:AV5,AR6:AW6,AR7:AS7;AT8:AX8"
Const RowOffset As Long = 1
Const ColOffset As Long = 0
If Target.Cells.CountLarge = 1 Then
Dim ColRanges() As String: ColRanges = Split(ColRangesList, ",")
Dim RowRanges() As String: RowRanges = Split(RowRangesList, ",")
Dim crg As Range, rrg As Range, cel As Range
Dim n As Long
For n = 0 To UBound(ColRanges)
Set crg = Columns(ColRanges(n))
Set rrg = Range(RowRanges(n))
If Not Intersect(Target, crg) Is Nothing Then
Set cel = rrg.Find(Target.Value, rrg.Cells(rrg.Cells.Count), _
LookIn:=xlFormulas, LookAt:=xlWhole)
If Not cel Is Nothing Then
Application.ScreenUpdating = False
Application.EnableEvents = False
Target.Value = cel.Offset(RowOffset, ColOffset).Value
Application.EnableEvents = True
Application.ScreenUpdating = True
Exit For
End If
End If
Next n
End If
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
I would like to use vba to carry out conditional formatting.
I want to format cell backround containing string Yes with green and red for string No. Earlier, I used a For loop but since the data is huge the algorithm takes a lot of time and excel becomes non responsive.
Then I tried to use Private Sub Worksheet_Change(ByVal Target As Range) to detect the change in cell and to apply colors to it but it does not work as it is supposed to.
This is what I have tried so far:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRange As Range
Dim KeyCells As Range
Set KeyCells = Range("A1:A10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Set MyRange = ActiveCell
MyRange.Select
If MyRange.Value = "Yes" Then
MyRange.Interior.ColorIndex = 35
MyRange.Font.ColorIndex = 50
ElseIf MyRange.Value = "No" Then
MyRange.Interior.ColorIndex = 22
MyRange.Font.ColorIndex = 9
Else
MyRange.Value = ""
MyRange.Interior.ColorIndex = xlNone
MyRange.Font.ColorIndex = 1
End If
End If
End Sub
In support of my comment, here is the fix
Private Sub Worksheet_Change(ByVal target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A1:A10")
If Not Application.Intersect(KeyCells, Range(target.Address)) _
Is Nothing Then
If target.Value = "Yes" Then
target.Interior.ColorIndex = 35
target.Font.ColorIndex = 50
ElseIf target.Value = "No" Then
target.Interior.ColorIndex = 22
target.Font.ColorIndex = 9
Else
target.Value = ""
target.Interior.ColorIndex = xlNone
target.Font.ColorIndex = 1
End If
End If
End Sub
You need to be aware that a change can be made to more than one cell at once. E.g. If user pastes a value into a range - or selects a range and then deletes.
To work around this, you cycle through each cell in the changed area.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRange As Range
Dim KeyCells As Range
Set KeyCells = Range("A1:A10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Application.EnableEvents = False
For Each MyRange In Application.Intersect(KeyCells, Range(Target.Address)).Cells
If MyRange.Value = "Yes" Then
MyRange.Interior.ColorIndex = 35
MyRange.Font.ColorIndex = 50
ElseIf MyRange.Value = "No" Then
MyRange.Interior.ColorIndex = 22
MyRange.Font.ColorIndex = 9
Else
MyRange.Value = ""
MyRange.Interior.ColorIndex = xlNone
MyRange.Font.ColorIndex = 1
End If
Next
Application.EnableEvents = True
End If
End Sub
Testing:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyRange As Range
Dim KeyCells As Range
Set KeyCells = Range("A1:A10")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
With Target
If .Value = "Yes" Then
.Interior.ColorIndex = 35
.Font.ColorIndex = 50
ElseIf .Value = "No" Then
.Interior.ColorIndex = 22
.Font.ColorIndex = 9
ElseIf .Value = "" Then
.Interior.ColorIndex = xlNone
.Font.ColorIndex = 1
End If
End With
End If
End Sub
If your cells to check will always be A1:A10, or some other range that will never change, then I agree that conditional formatting is the way to go. If you have several columns to check and they are not always static, then building a find function might be easier. Here is one that you can send a range to and the text you are searching for:
Sub testFindAndColor()
Dim bg1 As Long, bg2 As Long
Dim fg1 As Long, fg2 As Long
Dim myRange As Range
Dim stringToFind As String
bg1 = 50: bg2 = 9
fg1 = 35: fg2 = 22
Set myRange = ActiveSheet.Range("A1:A30")
stringToFind = "Yes"
Run findAndColorize(myRange, stringToFind, bg1, fg1)
Set myRange = Nothing
End Sub
Function findAndColorize(myRange As Range, textToSearchFor As String, backLongColor As Long, foreLongColor As Long)
Dim newRange As Range
With myRange
Set c = .Find(textToSearchFor, LookIn:=xlValues, MatchCase:=False)
If Not c Is Nothing Then
firstAddress = c.Address
Do
c.Interior.ColorIndex = backLongColor
c.Font.ColorIndex = foreLongColor
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Set c = Nothing
End Function