I am trying to write a macro that changes colors based on a value in Column L. If the cell in Column L is YES, then Hightlight Column B cell in Red. However, the Macro below doesn't work or fail. It runs but does nothing.
Sub ColorMeElmo()
Dim i As Long, r1 As Range, r2 As Range
For i = 2 To 5
Set r1 = Range("L" & i)
Set r2 = Range("B" & i & ":B" & i)
If r1.Value = "YES" Then r2.Interior.Color = vbRed
Next i
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CCell As Range
Dim sht As Worksheet
Set CCell = Range("L:L")
Set sht = Worksheets("SheetName")
If Target.Count = 1 Then
If Not Application.Intersect(CCell, Range(Target.Address)) _
Is Nothing Then
If Target.Value = "YES" Then
sht.Cells(Target.Row, 2).Interior.Color = RGB(255, 0, 0)
End If
End If
End If
End Sub
Put this in Sheet you want to watch.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim CCell As Range
Dim sht As Worksheet
Set CCell = Range("L:L")
Set sht = Worksheets("Sheet1") 'EDIT
If Target.Count = 1 Then
If Not Application.Intersect(CCell, Range(Target.Address)) _
Is Nothing Then
If Target.Value = "YES" Then
sht.Cells(Target.Row, 2).Interior.Color = RGB(255, 0, 0)
End If
End If
End If
End Sub
Related
I'm working on a macro that highlighted & colors the empty cells in a specific column (AE), but I need to clear this color-highlighted based on a result that exists in the column (AD)
If AD column, cells value = "SPLICE" clear color, If Empty the color should exist, below picture explains more.
I use the code below
Sub EmptyTerminalTO()
Application.ScreenUpdating = False
Sheets("Wire List").Activate
Dim i As Long
Dim c As Long
Dim myRange As Range
Dim myCell As Range
Set myRange = Range("AD2", Range("AD" & Rows.Count).End(xlUp))
For Each myCell In myRange '
c = c + 1
If (myCell) = "" Then
myCell.Interior.Color = RGB(255, 87, 87)
i = i + 1
End If
Next myCell
Rapport8 = i
Application.ScreenUpdating = True
End Sub
try using offset as per code below:
Option Explicit
Sub EmptyTerminalTO()
Application.ScreenUpdating = False
Sheets("Wire List").Activate
Dim i As Long
Dim c As Long, Rapport8 As Long
Dim myRange As Range
Dim myCell As Range
Set myRange = Range("AD2", Range("AD" & Rows.Count).End(xlUp))
For Each myCell In myRange '
c = c + 1
If myCell <> "SPLICE" & myCell.Offset(0, 1)="" Then
myCell.Offset(0, 1).Interior.Color = RGB(255, 87, 87)
Else
myCell.Offset(0, 1).Interior.Pattern = xlNone
i = i + 1
End If
Next myCell
Rapport8 = i
End Sub
Been working/researching on this code I am developing for my workplace tasking sheet. First part calls for the 'movebasedonvalue' macro when column F indicates task is closed. Second part, what my goal is to reassign a new UID with the macro 'NewUID', which as a stand alone works; I am attempting to have it called as soon as a cell in specified range within column B is blank.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Z As Long
Dim xVal As String
On Error Resume Next
If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Z = 1 To Target.Count
If Target(Z).Value > 0 Then
Call movebasedonvalue 'Macro to select row and move row content to specified sheet
End If
Next
Application.EnableEvents = True
End Sub
Private Sub FillBlanks(ByVal Target As Range)
Dim rngBlanks As Range
Dim ws As Worksheet
Set rngBlanks = Range("B4:B8,B10:B14,B16:20") 'Specifying the range
Set ws = ThisWorkbook.Worksheets("Burnout_Chart") 'Specifing Worksheet
With ws
If WorksheetFunction.CountBlank(rngBlank) > 0 Then 'wanting to identify blank cells in specified range
For Each area In rngBlanks.SpecialCells(xlCellTypeBlanks).Areas 'Trying to
Call NewUID 'Inputs new Unique ID into blank cell of Column B
Next
End If
End With
End Sub
Here is my movebasedonvalue code:
Sub movebasedonvalue()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
A = Worksheets("Burnout_Chart").UsedRange.Rows.Count
B = Worksheets("Completed").usedRange.Rows.Count
If B = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Completed").UsedRange) = 0 Then B = 0
End If
Set xRg = Worksheets("Burnout_Chart").Range("F4:F" & A)
On Error Resume Next
Application.ScreenUdating = False
For C = 1 To xRg.Count
If CStr(xRg(C).Value) = "Closed" Then
xRg(C).EntireRow.Copy Destination:=Worksheets("Completed").Range("A" & B + 1)
xRg(C).EntireRow.ClearContents
If CStr(xRg(C).Value) = "Closed" Then
C = C - 1
End If
B = B + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Here is my NewUID code:
Sub NewUID(c As Range)
Dim AR As Long
Dim MaxID As Long
Dim NewID As Long
Dim Burnout As Worksheet
Dim UID As Range
Set Burnout = ThisWorkbook.Sheets("Burnout_Chart")
Set UID = Range("B4:B8,B10:B14,B16:B20")
MaxID = Application.WorksheetFunction.Max(UID)
NewID = MaxID + 1
AR = ActiveCell.Row
ActiveCell.Value = NewID 'code to add id to cell c
End Sub
EDIT3: my last guess
Something like this should work
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range, rngUID As Range, nextID, nextRow As Long
Dim wsComp As Worksheet
On Error GoTo haveError
Set rng = Intersect(Target, Me.Range("F:F"))
If Not rng Is Nothing Then
Set wsComp = ThisWorkbook.Worksheets("Completed")
nextRow = NextEmptyRow(wsComp)
Application.EnableEvents = False
For Each c In rng.Cells
If c.Value = "Closed" Then
With c.EntireRow
.Copy wsComp.Cells(nextRow, "A")
.ClearContents
nextRow = nextRow + 1
End With
End If
Next c
Application.EnableEvents = True
End If
Set rngUID = Me.Range("B4:B8,B10:B14,B16:B20")
Set rng = Intersect(Target, rngUID)
If Not rng Is Nothing Then
nextID = Application.Max(rngUID) + 1 'next ID
Application.EnableEvents = False
For Each c In rng.Cells
If Len(c.Value) = 0 Then 'if cell is blank then assign an ID
c.Value = nextID
nextID = nextID + 1
End If
Next c
Application.EnableEvents = True
End If
Exit Sub
haveError:
Application.EnableEvents = True 'make sure events are re-enabled
End Sub
'given a worksheet, return the row number of the next empty row
Function NextEmptyRow(ws As Worksheet) As Long
Dim f As Range
Set f = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
If f Is Nothing Then
NextEmptyRow = 1
Else
NextEmptyRow = f.Row + 1
End If
End Function
I figured out my issue, there's a lot that needs to be cleaned up but here is the code I got working for what I need:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Z As Long
Dim xVal As String
Dim KeyCells As Range 'redundant (Choose one or the other)
Dim UID As Range 'redundant (Choose one or the other)
Dim AR As Long
Dim MaxID As Long
Dim NewID As Long
Dim Burnout As Worksheet
On Error Resume Next
Set KeyCells = Range("B4:B8,B10:14,B16:B20") 'redundant (Choose one or the other)
Set UID = Range("B4:B8,B10:B14,B16:B20") 'redundant (Choose one or the other)
Set Burnout = ThisWorkbook.Sheets("Burnout_Chart")
If Intersect(Target, Range("F:F")) Is Nothing Then Exit Sub
Application.EnableEvents = False
For Z = 1 To Target.Count
If Target(Z).Value > 0 Then
Call movebasedonvalue
End If
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
MaxID = Application.WorksheetFunction.Max(UID)
NewID = MaxID + 1
AR = ActiveCell.Row
Range("B" & AR).Select 'This is what I was missing
ActiveCell.Value = NewID
End If
Next
Application.EnableEvents = True
End Sub
Sub Macro5()
Dim rng As Range
Set rng = Selection
For Each cell In rng
ActiveCell.Value = ActiveCell.Value + 1
Next
End Sub
Quick fix for your code would be
Sub Macro5()
Dim rng As Range
Set rng = Range("B2:B10")
Dim cell As Range
For Each cell In rng
cell.Value = cell.Value + 1
Next
End Sub
Update: By the comment I guess you would like to use the SelectionChange Event. Put the following code into the code module of the sheet
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo EH
Application.EnableEvents = False
Dim rg As Range
Set rg = Range("B2:B12")
If Not (Intersect(rg, Target) Is Nothing) Then
Dim sngCell As Range
' This will only increase the values of the selected cells within B2:B10
' Not sure if this is wanted. Otherwise just modify according to your needs
For Each sngCell In Intersect(Target, rg)
sngCell.Value = sngCell.Value + 1
Next sngCell
End If
EH:
Application.EnableEvents = True
End Sub
Update 2: If you want to run the code via a button put the following code into a standard module and assign it to a button you create on the sheet
Sub Increase()
On Error GoTo EH
Application.EnableEvents = False
Dim rg As Range
Set rg = Range("B2:B10")
If Not (Intersect(rg, Selection) Is Nothing) Then
Dim sngCell As Range
For Each sngCell In Intersect(Selection, rg)
sngCell.Value = sngCell.Value + 1
Next sngCell
End If
EH:
Application.EnableEvents = True
End Sub
Test if the current cell is within your range!
Sub Macro5()
Dim rng As Range
Dim fixed_rng As Range
Set rng = Selection
Set fixed_rng = Range("B1:B10")
if Application.Union(rng, fixed_rng) = fixed_rng then
For Each cell In rng
ActiveCell.Value = ActiveCell.Value + 1
Next
End If
End Sub
I am trying to write a macro that will update all cells in a column that have the same value as the adjacent column below are before and after of what I am trying to accomplish. In this example you would update B1 and then any cells in A1 with the same value would update to the B1 value
Here is the code I am using
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim cel As Range
Set rng1 = Range("A1", Range("A2").End(xlDown))
For Each cel In rng1
If cel = Target.Offset(0, -1).Value Then
cel.Offset(0, 1).Value = Target.Value
End If
Next cel
End Sub
I am not sure if what I wrote is correct, but I keep getting out of stack space error, which I think is from the macro continuously looping every time through changing the same cells. I believe this should be possible but I am a little lost.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column <> 2 Then Exit Sub
Application.ScreenUpdating = False
For Each cel In Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
If cel = Target.Offset(, -1) Then
cel.Offset(, 1) = Target
End If
Next cel
Application.ScreenUpdating = True
End Sub
I would try to avoid looping if possible. Perhaps use a UDF instead, using the .Find() method?
Option Explicit
Function myLookup(ByVal rng As Range) As String
Application.Volatile
Dim ws As Worksheet, lookupRng As Range, retRng As Range
Set ws = rng.Parent
With ws
Set lookupRng = .Range(.Cells(1, rng.Column), .Cells(rng.Row - 1, rng.Column))
End With
Set retRng = lookupRng.Find(rng.Value, ws.Cells(1, rng.Column))
If retRng Is Nothing Then
myLookup = vbNullString
Else
With retRng
myLookup = ws.Cells(.Row, .Column + 1)
End With
End If
End Function
You would place this UDF in the worksheet as follows:
and fill down. This will prevent circular references because it will search for the cells above it only within the lookupRng.
And, the final result:
Sub sel_to_array()
Dim arr As Variant
Dim i
Sheets("Ps").Activate
Sheets("Ps").Range("C6").Select
Range(Selection, Selection.End(xlDown)).Select
'arr = ActiveCell.CurrentRegion.Value
arr = Selection
For Each i In arr
MsgBox i
If Round(i, 0) = Round(proj_cbox.Value, 0) Then
GoTo 1:
End If
Next i
End Sub
Here is what it does: when it finds the equal match, I want to know what its cell location is, for example A3 or A13.
Try this
Sub sel_to_array()
Dim arr As Range, rng As Range, cell As Range
Dim lastRow As Long
Sheets("Ps").Activate
lastRow = Sheets("Ps").Range("C" & Rows.Count).End(xlUp).Row
If lastRow <= 5 Then Exit Sub
Set rng = Range("C6:C" & lastRow)
For Each cell In rng
If Round(cell.Value, 0) = Round(proj_cbox.Value, 0) Then
MsgBox cell.Address
End If
Next
End Sub
Not sure why you are bouncing the range to an array. If that is not really needed you could try this:
Sub sel_to_address()
Dim MyRange As Range
For Each MyRange In Range(Sheets("Ps").Range("C6"), Sheets("Ps").Range("C6").End(xlDown))
MsgBox MyRange.Value
If Round(MyRange.Value, 0) = Round(proj_cbox.Value, 0) Then
MsgBox MyRange.Address
End If
Next MyRange
End Sub
Try:
MsgBox i.Address
or you could do this
Set arr = Selection 'set here forces arr to a range object
If Round(i, 0) = Round(proj_cbox.Value, 0) Then
With i.Interior
.Pattern = xlSolid
.ColorIndex = 36 'Light Yellow
End With
Else
i.Interior.ColorIndex = xlNone
End If
which will shade all cells with light yellow that match the value, and clear shading from all cells that don't.