I'm trying to select an item in Pivot Slicer when I change "A1" value.
So when I change the "A1" value to "ABC" the code should look for "ABC" in the Slicer Item and select it.
"A1" value will be same as the items in the slicer.
Here is my try, but doesn't seems to work and doesn't look right :(
Private Sub WorkSheet_Change(ByVal Target As Range)
Dim i As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
If Not Intersect(Target, Range("A1")) Is Nothing Then
For i = 1 To ActiveWorkbook.SlicerCaches("Slicer_Test").SlicerItems.Count
If ActiveWorkbook.SlicerCaches("Slicer_Test").SlicerItems(i).Value = ActiveSheet.Range("A1") Then
ActiveWorkbook.SlicerCaches("Slicer_Test").SlicerItems(i).Selected = True
Else
ActiveWorkbook.SlicerCaches("Slicer_Test").SlicerItems(i).Selected = False
End If
Next
End If
End Sub
Thank you in advance.
I was able to find something that would works.
This is not perfect but works, but still looking for a better way to do this.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
If Not Intersect(Target, Range("A1")) Is Nothing Then
ActiveWorkbook.SlicerCaches("Slicer_Test").Slicers(1).SlicerCache.ClearAllFilters
For i = 1 To ActiveWorkbook.SlicerCaches("Slicer_Test").SlicerItems.Count
If ActiveWorkbook.SlicerCaches("Slicer_Test").SlicerItems(i).Value <> ActiveSheet.Range("A1") Then
ActiveWorkbook.SlicerCaches("Slicer_Test").SlicerItems(i).Selected = False
End If
Next
End If
End Sub
Related
Can someone help me with the following scenario:
If A1 in sheet1 is equal to "W1" how do I make a VBA so B2 in sheet2 is equal to "Goodmorning Monday".
I have to make so if A1 in Sheet1 is changed to "W2" then B2 in sheet2 is equal to "Goodmorning Tuesday".
I have tried the following code:
Sub Datesss()
If Sheets("Sheet1").Range("A1") = "W1" Then
Sheets("Sheet2").Range("B2") = "Goodmorning Monday"
or
If Sheets("Sheet1").Range("A1") = "W2" Then
Sheets("Sheet2").Range("B2") = "Goodmorning Tuesday"
End Sub
A Worksheet Change: As Simple As It Gets
Copy the following code to the sheet code module of worksheet Sheet1. In the VBE Project Explorer, the name not in parentheses is the sheet code name which will also be displayed in the window in VBA, while the name in parentheses is the tab name.
There is nothing to run, it runs automatically.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim WDays(): WDays = VBA.Array("W1", "W2", "W3", "W4", "W5", "W6", "W7")
Dim Days(): Days = VBA.Array("Monday", "Tuesday", "Wednesday", _
"Thursday", "Friday", "Saturday", "Sunday") _
Dim sws As Worksheet: Set sws = Me ' worksheet containing this code
Dim sCell As Range: Set sCell = sws.Range("A1")
Dim tCell As Range: Set tCell = Intersect(sCell, Target)
If tCell Is Nothing Then Exit Sub
Dim tValue As Variant: tValue = tCell.Value
Dim tIndex As Variant: tIndex = Application.Match(tValue, WDays, 0)
If IsError(tIndex) Then Exit Sub
Dim dws As Worksheet: Set dws = sws.Parent.Sheets("Sheet2")
Dim dCell As Range: Set dCell = dws.Range("B2")
dCell.Value = "Good Morning " & Days(tIndex - 1)
End Sub
Please, copy the next code in "Sheet1" code module:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.address(0, 0) = "A1" Then
Dim sh2 As Worksheet: Set sh2 = Worksheets("Sheet2")
If Target.Value Like "W?" Then
If CLng(Mid(Target.Value, 2)) > 0 And CLng(Mid(Target.Value, 2)) <= 7 Then
sh2.Range("B2").Value = "Goodmorning " & getDayName(Mid(Target.Value, 2)) 'Monday"
End If
End If
End If
End Sub
Function getDayName(dayNo As Long) As String
Dim arrDaysName: arrDaysName = Split("Monday,Tuesday,Wednesday,Thurstay,Friday,Saturday,Sunday", ",")
getDayName = arrDaysName(CLng(dayNo))
End Function
Change "A1" cell content and check what happens in "Sheet2", "B2" cell...
Of course, it will do something only for suffix numbers between 1 and 7...
You can use the built in functions in Code behind sheet.
Goto your VBA projects (Alt+F11), and then open the Project Explorer (Ctrl+R)
Double Click Sheet1 and code area will show. Then paste this code in:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Worksheets("Sheet2").Cells(2, 2) = "Goodmorning Monday"
End If
End Sub
Whenever any Cell in Sheet1 is changed this code runs. And by checking the Target. Address you can manipulate what ever you want. Remember to save your file as .xlsm ;-)
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
So I know that one can format cells to be locked and then protect a worksheet to prevent that data being overwritten. But I'm looking to be able to dynamically lock cells within a sheet. From doing some Googling I've tried adapting the below block of code for my needs. The intent is that if column A has a value the rest of the row will be locked so no one can overwrite the rest of the row.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(ActiveSheet.Cells(18, 1), Target) Is Not Nothing Then
If ActiveSheet.Cells(18, 1).Text = "X" Then
ActiveSheet.Range(Cells(18, 2), Cells(18, 20)).Locked = True
Else
ActiveSheet.Range(Cells(18, 2), Cells(18, 20)).Locked = False
End If
End If
End Sub
Any help would be much appreciated, as well as tips for succinctly applying this to every row in the sheet.
UPDATE:
Per BigBen's answer I've revised to the following:
Private Sub Workbook_Open()
Sheets(“Sheet8”).Protect Password:="Secret", UserInterFaceOnly:=True
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Me.Columns(1), Target)
If rng Is Nothing Then Exit Sub
Dim cell As Range
For Each cell In rng
cell.EntireRow.Locked = (cell.Value = "X")
Next
End Sub
But that still doesn't seem to be working...
You need to change the Intersect to test if Target intersects column A, and not a particular cell:
Note also the Not syntax: If Not Intersect... Is Nothing, instead of If Intersect... Is Not Nothing.
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Me.Columns(1), Target) Is Nothing Then
Dim rng as Range
For Each rng in Intersect(Me.Columns(1), Target)
If rng.Value = "X" Then
rng.EntireRow.Locked = True
Else
rng.EntireRow.Locked = False
End If
Next
End If
End Sub
Or perhaps a bit more succinctly:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range
Set rng = Intersect(Me.Columns(1), Target)
If rng Is Nothing Then Exit Sub
Dim cell As Range
For Each cell In rng
cell.EntireRow.Locked = (cell.Value = "X")
Next
End Sub
I need a sheet in Excel to activate if any cells in a column are selected as "Yes", but my VBA code won't stick - simple enough to do for one cell, but the whole column is throwing me. The cells are a drop down list with solely the options "Yes" or "No"
Currently trying:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$H$11:$H$23" Then
If ActiveWorkbook.Worksheets("Sheet1").Range("H11:H23").Value = "Yes" Then
Sheets("Sheet2").Visible = True
Else
Sheets("Sheet2").Visible = False
End If
End If
End Sub
Any tips? Thanks
An easier solution without looping would be to count the Yes using WorksheetFunction.CountIf method.
Use the following to show Sheet2 if at least one cell has the Yes.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim TestRange As Range
Set TestRange = Me.Range("H11:H23")
If Not Application.Intersect(Target, TestRange) Is Nothing Then 'if target is in test range
If Application.WorksheetFunction.CountIf(TestRange, "Yes") > 0 Then
Worksheets("Sheet2").Visible = True
Else
Worksheets("Sheet2").Visible = False
End If
End If
End Sub
If all cells in the test range need to be Yes then change it to
If Application.WorksheetFunction.CountIf(TestRange, "Yes") = TestRange.Cells.Count Then
i think you could try:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range, rng As Range
Dim Inrng As Boolean
If Not Intersect(Target, Me.Range("H11:H23")) Is Nothing Then
'Set a boolean variable to false
Inrng = False
'Set a range to loop
Set rng = Me.Range("H11:H23")
'Start looping the range
For Each cell In rng
'Convert the value of a cell to Upper case to avoid case sensitive issues
If UCase(cell.Value) = "YES" Then
'Turn the variable to true if value appears in the range
Inrng = True
'Exit the loop to avoid time consuming
Exit For
End If
Next cell
If Inrng = True Then
Worksheets("Sheet2").Visible = True
Else
Worksheets("Sheet2").Visible = False
End If
End If
End Sub
I am very new to the World of VBA. I am attempting to add to an existing Private Sub(Change). I am trying to "fire" the Macro "DelRCE" When the Active Cell in Range("K2:K700") Does Not equal the word "Down".
The code below is not working:
Dim txt As String
Dim rng As Range
Dim vec As String
txt = ActiveCell.Value
rng = ("K2:K700")
vec = "Down"
If r_ng.txt <> vec Then
Call Macro
End If
I assume you are looking for something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
Dim key As String
Dim rng As Range
'Set the word you want to search for. Take capital letters into account
key = "down"
'Set worksheet to the first sheet in your workbook
Set ws = ThisWorkbook.Sheets(1)
'Change this to the range you want to search
Set rng = ws.Range("A1:A100")
'Check if the target is in the range
If Not Intersect(Target, rng) Is Nothing Then
If Target.Value <> key Then
'Change this to you function call
MsgBox "The target is inside the range and the value is different from '" & key & "'"
End If
End If
End Sub
Put the cursor inside the test_Change sub and hit PF5 to run it.
private Sub Change()
Dim txt As String
Dim rng As Range
Dim vec As String
txt = ActiveCell.Value
rng = ("K2:K700")
vec = "Down"
If r_ng.txt <> vec Then
Call DelRCE ' or "Run DelRCE" if it is a function
End If
End Sub
Private Sub test_Change()
call Change
End Sub
Add the code below to the relevent Worksheet module, under the Worksheet_Change event:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim vec As String
vec = "Down"
If Not Intersect(Target, Range("K2:K700")) Is Nothing Then ' check that modifed cell is inside the Range("K2:K700")
If Target.Count > 1 Then Exit Sub ' Optional : if more than 1 cell selected exut the sub
If Not Target.Value Like vec Then ' Also possible to use: If Target.Value <> vec
Call Macro
End If
End If
End Sub