I'm trying to find a last row until next highlighted cell and clear the range.
Range("B2").End(xlDown) won't work, I found something called xlCellTypeSameFormatConditions under SpecialCells but not sure how this could be applied.
Maybe there is a better method?
The result should clear Range B2:B7 only
Ok so combining both solution into one I have it like this
Private Sub WorkSheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Target, Range("A1")) Is Nothing Then
Dim rngCheck, rngCell As Range
Set rngCheck = ActiveSheet.Range("B2:B" & Cells(2, 2).End(xlDown).Row)
For Each rngCell In rngCheck
If rngCell.Interior.Pattern = xlNone Or rngCell.Value = "" Then rngCell.Value = ""
Next
Set rngCheck = Nothing
End If
End Sub
So basically when value in "A1" changes, trigger a clear.
The same code works under Module but not with WorkSheet_Change
You could try:
Sub test()
Dim rng As Range
With Application.FindFormat
.Clear
.Interior.Color = vbWhite
End With
With ThisWorkbook.Sheets("Sheet1") 'Change to correct sheetname
Set rng = .Range("B2:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
rng.Cells.Replace What:="*", Replacement:="", SearchFormat:=True
End With
End Sub
If you want to run the code on a sheet change event try the below:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Debug.Print Target.Address
Application.EnableEvents = False
If Target.Address = "$A$1" Then
With Application.FindFormat
.Clear
.Interior.Color = vbWhite
End With
Set rng = Range("B2:B" & Cells(2, 2).End(xlDown).Row)
rng.Cells.Replace What:="*", Replacement:="", SearchFormat:=True
End If
Application.EnableEvents = True
End Sub
Try this, note there is no exception or error handling. This will stop as soon as it hits a highlighted cell no matter what colour, and will not remove non-highlighted cells which are between highlighted cells.
Sub MoveToNextHighlightedCell()
Do Until Not ActiveCell.Interior.Pattern = xlNone Or ActiveCell.Value = ""
ActiveCell.Value = ""
ActiveCell.Offset(1, 0).Select
Loop
End Sub
Alternatively use this, it will not stop unless there are missing values. Updated as per comment from #Mikku.
Sub MoveToNextHighlightedCell()
Dim rngCheck, rngCell As Range
Set rngCheck = ActiveSheet.Range(ActiveCell, ActiveCell.End(xlDown))
For Each rngCell In rngCheck
If rngCell.Interior.Pattern = xlNone Or rngCell.Value = "" Then rngCell.Value = ""
Next
Set rngCheck = Nothing
End Sub
Related
I'm struggle with this situation.
I have these 2 macros that do not work together in the same worksheet.
First
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Dim cell As Range
Set rng = Intersect(Target, Range("C:C"))
' Exit if no updates made to desired range
If rng Is Nothing Then Exit Sub
' Loop through cells just updated
Application.EnableEvents = False
For Each cell In rng
Cells(cell.Row, "B") = Application.UserName
Cells(cell.Row, "A") = Format(Date, "dd.mm.yyyy")
Next cell
Application.EnableEvents = True
End Sub
And second
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng1 As Range
Dim cell As Range
Set rng1 = Intersect(Target, Range("G:G"))
' Exit if no updates made to desired range
If rng1 Is Nothing Then Exit Sub
' Loop through cells just updated
Application.EnableEvents = False
For Each cell In rng1
Cells(cell.Row, "F") = Application.UserName
Cells(cell.Row, "E") = Format(Date, "dd.mm.yyyy")
Next cell
Application.EnableEvents = True
End Sub
I tried to get application.username in a specific column but the same row with the modified cell from another specific column. All of this but different ranges, in the same worksheet. Is it possible to combine these 2 macros in only one?
Obviously, you can't have 2 routines with the same name, you will need to merge the codes together.
Naive attempt:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
Set rng = Intersect(Target, Range("C:C"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng
Cells(cell.Row, "B") = Application.UserName
Cells(cell.Row, "A") = Format(Date, "dd.mm.yyyy")
Next cell
End If
Set rng = Intersect(Target, Range("G:G"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng
Cells(cell.Row, "F") = Application.UserName
Cells(cell.Row, "E") = Format(Date, "dd.mm.yyyy")
Next cell
End If
Application.EnableEvents = True
End Sub
However, as you do exactly the same for column C and column G (writing name and date to the 2 cells left of the modified cell(s)), you can simplify the code by using Union to check if cells where modified in column C or column G and use the Offset-function to access the cells to the left:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
Set rng = Intersect(Target, Union(Range("C:C"), Range("G:G")))
If rng Is Nothing Then Exit Sub
Application.EnableEvents = False
For Each cell In rng
cell.Offset(0, -1) = Application.UserName
cell.Offset(0, -2) = Format(Date, "dd.mm.yyyy")
Next cell
Application.EnableEvents = True
End Sub
This is exactly what I was looking for, for both to work together. I was thinking now how to add to the IF line so that if I delete cell on column C:C or G:G, and they remain blank/empty, to automatically delete the content from columns A and B as well.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, cell As Range
Set rng = Intersect(Target, Range("C:C"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng
If cell.Value = "" Then
Cells(cell.Row, "B").ClearContents
Cells(cell.Row, "A").ClearContents
Else
Cells(cell.Row, "B") = Application.Username
Cells(cell.Row, "A") = Format(Date, "dd.mm.yyyy")
End If
Next cell
End If
Set rng = Intersect(Target, Range("F:F"))
If Not rng Is Nothing Then
Application.EnableEvents = False
For Each cell In rng
If cell.Value = "" Then
Cells(cell.Row, "E").ClearContents
Cells(cell.Row, "D").ClearContents
Else
Cells(cell.Row, "E") = Application.Username
Cells(cell.Row, "D") = Format(Date, "dd.mm.yyyy")
End If
Next cell
End If
Application.EnableEvents = True
End Sub
Works like a charm.
Thanks FunThomas for your quick help.
I´m trying to sort columns by value set in a drop down list.
I have got it to work for one column.
Value set in cell: B1
Sort Column A from A5 and hide cells not containing that value.
But I want to be able to sort multiple columns (A, B and C)via value in B1 and hide all rows not containing that specific value. See attatched image. Link:
https://i.stack.imgur.com/9NqC3.png
The working code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B1")) Is Nothing Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Len(Range("B1").Value) > 0 Then Range("A5", Range("A" & Rows.Count).End(xlUp)).AutoFilter Field:=1, Criteria1:=Range("B1").Value
End If
End Sub
Please, try the next adapted code:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long, C As Range, rngDel As Range
If Target.Address = "$B$1" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Target.Value <> "" Then
lastR = Me.Range("A" & Rows.count).End(xlUp).row
With Me.Range("A5:C" & lastR)
.AutoFilter field:=1, Criteria1:=Target.Value
For Each C In Me.Range("B6:C" & lastR)
If C.Value = Target.Value Then
If rngDel Is Nothing Then
Set rngDel = C
Else
Set rngDel = Union(rngDel, C)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Hidden = False
End With
End If
End If
End Sub
Edited:
The following code works when your last workbook structure. Please, try learning and understanding it:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastR As Long, C As Range, rngDel As Range
If Target.Address = "$E$1" Then
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData
If Target.Value <> "" Then
lastR = Me.Range("B" & Rows.Count).End(xlUp).Row
With Me.Range("G1:J" & lastR)
.AutoFilter field:=1, Criteria1:=Target.Value
For Each C In Me.Range("G2:J" & lastR)
If C.Value = Target.Value Then
If rngDel Is Nothing Then
Set rngDel = C
Else
Set rngDel = Union(rngDel, C)
End If
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Hidden = False
End With
End If
End If
End Sub
You must use a complete filled column in order to calculate the last filled row!
The above code uses B:B column.
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:
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
I was wondering if this is possible:
I have a row of data on column A and is it possible that when I highlight (fill) say A1 in a color it will automatically copy/paste into E1?
If you are looking for a VBA solution this will work
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static PrevCell As Range
If Not PrevCell Is Nothing Then
If PrevCell.Column = 1 Then
If PrevCell.Interior.ColorIndex <> xlNone Then
PrevCell.Copy
Paste Cells(PrevCell.Row, "E")
Else
'In case you unhighlight the cell
Cells(PrevCell.Row, "E") = ""
Cells(PrevCell.Row, "E").Interior.ColorIndex = xlNone
End IF
End If
End If
Application.CutCopyMode = False
Set PrevCell = Target
End Sub
The assumption here is that all cells are using the standard fill of xlNone which means no fill. If you have cells that have other fill colors and you only want to capture when the cell is a certain color you will need to change it to
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static PrevCell As Range
If Not PrevCell Is Nothing Then
If PrevCell.Column = 1 Then
If PrevCell.Interior.ColorIndex = INSERT PROPER HIGHLIGHTING COLOR INDEX HERE Then
PrevCell.Copy
Paste Cells(PrevCell.Row, "E")
Else
'In case you unhighlight the cell
Cells(PrevCell.Row, "E") = ""
Cells(PrevCell.Row, "E").Interior.ColorIndex = xlNone
End IF
End If
End If
Application.CutCopyMode = False
Set PrevCell = Target
End Sub
Update
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static PrevCell As Range
Dim LastRow As Integer
Dim lcell As Range
If Not PrevCell Is Nothing Then
LastRow = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row
If PrevCell.Column = 1 Then
If PrevCell.Interior.ColorIndex <> xlNone Then
PrevCell.Copy
If Cells(LastRow, "E") <> "" Then
Paste Cells(LastRow + 1, "E")
Else
Paste Cells(LastRow, "E")
End If
Else
'In case you unhighlight the cell
For Each lcell In Sheet1.Range("$E$1", "$E$" & LastRow)
If lcell.Value = PrevCell.Value Then
lcell.Delete xlShiftUp
Exit For
End If
Next lcell
End If
End If
End If
Application.CutCopyMode = False
Set PrevCell = Target
End Sub
Issues: Everytime you enter a highlighted cell it will append the value to the list. If you have duplicate values in Column A un-highlighting 1 will remove only 1 from the running list in E. If you do not have duplicates in column A then you would need to institute a loop over E to determine if the value already exists. Like so :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Static PrevCell As Range
Dim LastRow As Integer
Dim lcell As Range
Dim isDuplicate AS Boolean
If Not PrevCell Is Nothing Then
LastRow = Sheet1.Cells(Rows.Count, "E").End(xlUp).Row
If PrevCell.Column = 1 Then
If PrevCell.Interior.ColorIndex <> xlNone Then
For Each lcell In Sheet1.Range("$E$1", "$E$" & LastRow)
If lcell.Value = PrevCell.Value Then
isDuplicate = True
Exit For
End If
Next lcell
If Not isDuplicate Then
PrevCell.Copy
If Cells(LastRow, "E") <> "" Then
Paste Cells(LastRow + 1, "E")
Else
Paste Cells(LastRow, "E")
End If
End If
Else
'In case you unhighlight the cell
For Each lcell In Sheet1.Range("$E$1", "$E$" & LastRow)
If lcell.Value = PrevCell.Value Then
lcell.Delete xlShiftUp
End If
Next lcell
End If
End If
End If
Application.CutCopyMode = False
Set PrevCell = Target
End Sub