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.
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 am working on Excel sheet in which I want to filter many columns together. For example, I have columns from B to G and there are data validations lists on the first cell of each columns to select. I made the code when we select the data the column changes. When I apply the same on the next column, I get the data on the second column, but it removes the filter on the first column. What I want is to process filters on all columns together,
Here is my code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row
With Me
If Not Intersect(Target, .Range("B1")) Is Nothing Then
If Target.Value <> "" Then
.AutoFilterMode = False
.Range("B2:B" & lastrow).AutoFilter Field:=1, Criteria1:=Target.Value
End If
End If
If Not Intersect(Target, .Range("C1")) Is Nothing Then
If Target.Value <> "" Then
.AutoFilterMode = False
.Range("C2:C" & lastrow).AutoFilter Field:=1, Criteria1:=Target.Value
End If
End If
End With
End Sub
What I need to do to make the two filters work together.
I think you want this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
Dim rCriteria As Range
Dim i As Long
lastrow = Cells(Rows.Count, "C").End(xlUp).Row
With Me
Set rCriteria = .Range("B1:C1")
If Not Intersect(Target, rCriteria) Is Nothing Then
.AutoFilterMode = False
For i = 1 To rCriteria.Count
If rCriteria(i) <> "" Then
.Range("B2:C" & lastrow).AutoFilter Field:=i, Criteria1:=rCriteria(i)
End If
Next
End If
End With
End Sub
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
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'm having a problem with a macro because it give me Ambiguous name detected Worksheet_Change . If the user enter a value on any cell under column B it will run automatically a macro and if the user enter a value on column F it will run automatically another macro but I do not know how to fix this error . Please the the code below
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"))
If rng.Row > 2 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call MyMacro(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub MyMacro(rw As Long)
If Range("B" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("J" & rw & ":K" & rw) = Range("J" & rw & ":K" & rw).Value
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("F")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("F"))
If rng.Row > 3 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call Foolish(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub Foolish(rw As Long)
If Range("F" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("G" & rw & ":H" & rw) = Range("G" & rw & ":H" & rw).Value
End If
End Sub
You have two Worksheet_change() subs happening in your sheet. Copy the contents of one of those subroutines and paste it inside the other one so there is only one worksheet_change event.
For example:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Columns("B")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("B"))
If rng.Row > 2 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call MyMacro(rng.Row)
End If
Next rng
End If
If Not Intersect(Target, Columns("F")) Is Nothing Then
On Error GoTo Safe_Exit
Application.EnableEvents = False
Dim rng As Range
For Each rng In Intersect(Target, Columns("F"))
If rng.Row > 3 Then ' your sample code seemed to suggest that this should start on row 3 and higher
Call Foolish(rng.Row)
End If
Next rng
End If
Safe_Exit:
Application.EnableEvents = True
End Sub
Sub MyMacro(rw As Long)
If Range("B" & rw) = "" Then
MsgBox "Ingrese El account Number"
Else
Range("J" & rw & ":K" & rw) = Range("J" & rw & ":K" & rw).Value
End If
End Sub