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 ;-)
Related
I am working on a worksheet that will enter static date and time in an excel worksheet when a value is typed in a target cell. However, the worksheet will be used where values are copied from a downloaded file and pasted to the macro worksheet. When values are typed, the date and time worked as expected but if values are pasted, the VBA code does not work, it has to be typed. How can I make that possible?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Not Intersect(Target, Range("C2:C100")) Is Nothing Then
With Target(1, -1)
.Value = Date
.EntireColumn.AutoFit
End With
End If
End Sub
Something like this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, c As Range
'any updates to C2:C100 ?
Set rng = Application.Intersect(Target, Me.Range("C2:C100"))
If Not rng Is Nothing Then
'loop over all updated cells
For Each c In rng.Cells
c.Offset(0, -2).Value = Date
Next c
rng.Offset(0, -2).EntireColumn.AutoFit
End If
End Sub
Add Date Stamp on Cell Change
Pick one.
Easy
Private Sub Worksheet_Change(ByVal Target As Range)
Const cFirst As String = "C2"
Const dCol As String = "A"
Dim rg As Range
Set rg = Range(cFirst).Resize(Rows.Count - Range(cFirst).Row + 1)
Set rg = Intersect(Target, rg)
If Not rg Is Nothing Then
' Since you cannot manually paste a non-contiguous range
' (you can copy one), you can get away with the following line:
rg.EntireRow.Columns(dCol).Value = Date
rg.EntireColumn.AutoFit
End If
End Sub
Hard
Private Sub Worksheet_Change(ByVal Target As Range)
Const cFirst As String = "C2"
Const dCol As String = "A"
' Create a reference to the column range from 'cFirst'
' to the bottom-most cell in the worksheet.
Dim rg As Range: Set rg = Intersect(Target, _
Range(cFirst).Resize(Rows.Count - Range(cFirst).Row + 1))
If rg Is Nothing Then Exit Sub
' If you plan to populate the cells via VBA, then you could write
' non-contiguously to the column range,
' e.g. with 'Range("C3,C5:C7,C10:20").value = 1'.
' Then you could use the following:
Dim dDate As Date: dDate = Date
Dim arg As Range
For Each arg In rg.Areas
arg.EntireRow.Columns(dCol).Value = dDate
Next arg
rg.EntireColumn.AutoFit
End Sub
Tough
Private Sub Worksheet_Change(ByVal Target As Range)
addDateStamp Target, "C2", "A"
End Sub
' This is usually, but not necessarily, located in a standard module.
Sub addDateStamp( _
ByVal TargetRange As Range, _
ByVal FirstCellAddress As String, _
ByVal DateStampColumn As String)
If Not TargetRange Is Nothing Then
Dim rg As Range
With TargetRange.Worksheet.Range(FirstCellAddress)
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1)
End With
Set rg = Intersect(TargetRange, rg)
If Not rg Is Nothing Then
Dim dDate As Date: dDate = Date
Dim arg As Range
For Each arg In rg.Areas
arg.EntireRow.Columns(DateStampColumn).Value = dDate
Next arg
rg.EntireColumn.AutoFit
End If
End If
End Sub
I’m wanting to know if this is possible, and how would I go about doing so:
I’d like to be able to double click a cell (in column Z), reference what is in Column G of that same row, and then find and set focus from the info found in column G on another sheet.
So when I double click the cell in Z1 for example, it looks for what information is in G1 and finds it on another sheet and sets focus to that new cell.
Is this possible?
Thanks
Yes, you need to implement Worksheet_BeforeDoubleClick event handler then you may do anything you like, handler is an event of Worksheet object. Do your main code in Module code to keep things reusable across multiple sheets.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Cancel = True
Call Module1.onDrillDownToData(Target)
End Sub
- - -
Public Function onDrillDownToData(ByRef sender As Range)
Dim ws as worksheet
Dim iCol As Long
Dim iRow As Long
Dim dt As Date
set ws = sender.Parent
' do anything you want with worksheet
' sender is the origin cell
iCol = Sender.Column
iRow = Sender.Row
dt = Now()
ws.Cells(iRow, iCol).Value = "'" & Format(dt, "yyyy\-MM\-dd", vbMonday)
ws.Cells(iRow + 1, iCol).Value = "'" & Format(dt, "hh\:nn\:ss", vbMonday)
set ws = Application.Worksheets("TargetSheet")
ws.Activate
ws.Range("A5").Activate
End Function
Worksheet BeforeDoubleClick
Copy the following code into the sheet module of the sheet where you are going to double-click (In VBE in the project explorer double-click on the appropriate sheet to open its code window).
Before exiting VBE, adjust the constants, especially the destination worksheet name (wsName, the name in parentheses), in the code.
The Code
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
' Define constants.
Const wsName As String = "Sheet2" ' Destination Worksheet Name
Const SourceColumn As String = "Z" ' Source Column String
Const CriteriaColumn As String = "G"
' Not sure if this is even possible.
If Target.Rows.Count > 1 Then Exit Sub
If Not Intersect(Target, Columns(SourceColumn)) Is Nothing Then
Dim Criteria As Variant
Criteria = Cells(Target.Row, CriteriaColumn)
If Not IsError(Criteria) And Not IsEmpty(Criteria) Then
Dim cel As Range
With ThisWorkbook.Worksheets(wsName)
Set cel = .Cells _
.Find(What:=Criteria, _
After:=.Cells(.Rows.Count, .Columns.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
MatchCase:=False) ' Change to True is necessary
If Not cel Is Nothing Then
.Activate
cel.Select
End If
End With
End If
End If
End Sub
I am new to VBA and have been trying to get this to work for the last few days.
I have 2 columns.
B-student
C-date
What I want is when a student comes in and puts their initials in column B then it fills in the date in column C in that row.
Now if i delete the students initials I want it to clear the C cell also for that row.
Here is my code
Private Sub Worksheet_Change(ByVal Target As Range)
Dim wb As Workbook
Set wb = Workbooks("Training")
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet1")
Dim StaffRange As Range
Set StaffRange = ws.Range("B5:B40")
Dim StaffTime As Range
' If they put in initials in StaffRange then proceed
If Not Intersect(Target, StaffRange) Is Nothing Then
Set StaffTime = ws.Range("C" & Target.Row)
If StaffTime.Value <> "" Then Exit Sub 'if there is already a date then exit
StaffTime.Value = Now ' put in the date time
'now if they clear StaffRange then clear StaffTime
ElseIf Intersect(Target, StaffRange) Is Nothing Then
Set StaffTime = ws.Range("C" & Target.Row)
StaffTime.ClearContents ' make blank
End If
End Sub
Thank you for any and all help.
To fix your problem, just change references to .Value = "" to .clear.
As well, you need to add a reference to the sheet you are working within, otherwise, your reference to Range can "confuse" the macro.
Explanation
Dim wb As Workbook: Set wb = Workbooks(ThisWorkbook.Name) ' defines the workbook you are working in. You could change "ThisWorkbook" to the actual workbook name, but note that any changes to the workbook name (such as auto recover) will require you to modify this variable.
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' defines the worksheet within the workbook defined above.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim StaffRange As Range
Dim StaffTime As Range
Dim TrainerRange As Range
Dim TrainerTime As Range
Dim wb As Workbook: Set wb = Workbooks(ThisWorkbook.Name)
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Set StaffRange = ws.Range("B5:B40")
Set TrainerRange = ws.Range("D5:D40")
' If they put in initials in StaffRange then procede with entering the date stamp
If Not Intersect(Target, StaffRange) Is Nothing Then
Set StaffTime = ws.Range("C" & Target.Row)
If StaffTime.Value <> "" Then Exit Sub 'if there is already a date in field do not update and exit
StaffTime.Value = Now ' put in the date time
' now if they clear StaffRange then clear StaffTime
' cell cleared
ElseIf Intersect(Target, StaffRange) Is Nothing Then
Set StaffTime = ws.Range("C" & Target.Row)
' If StaffTime.Value = "" Then Exit Sub ' if it is already clear exit
StaffTime.clear ' make blank
' If they put in initials in TrainerRange then procede with entering the date stamp
ElseIf Not Intersect(Target, TrainerRange) Is Nothing Then
Set TrainerTime = ws.Range("E" & Target.Row)
If TrainerTime.Value <> "" Then Exit Sub
TrainerTime.Value = Now
' now if they clear TrainerRange then clear TrainerTime
' cell cleared
ElseIf Intersect(Target, TrainerRange) Is Nothing Then
clearing
Set StaffTime = ws.Range("E" & Target.Row)
' If StaffTime.Value = "" Then Exit Sub ' if it is already clear exit
StaffTime.clear ' make blank
End If
End Sub
You can do this:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim b As Range, c As Range, rng As Range
'updates in range of interest?
Set rng = Application.Intersect(Me.Range("B5:B40"), Target)
If rng Is Nothing Then Exit Sub 'nothing to process...
For Each b In rng.Cells
Set c = b.Offset(0, 1)
If Len(b.Value) > 0 Then
If Len(c.Value) = 0 Then c.Value = Now 'value entered: add time
Else
c.ClearContents 'value cleared: clear time
End If
Next b
End Sub
I got it to work. Thank you both for your code. I learned from both and came up with this.
If it can be cleaned up I would appreciate any pointers.
Thanks again
Private Sub Worksheet_Change(ByVal Target As Range)
Dim b As Range, c As Range, d As Range, e As Range, rngb As Range, rngd As Range
'updates in range of interest?
Set rngb = Application.Intersect(Me.Range("B5:B40"), Target)
Set rngd = Application.Intersect(Me.Range("D5:D40"), Target)
If Not rngb Is Nothing Then
For Each b In rngb.Cells
Set c = b.Offset(0, 1)
If Len(b.Value) > 0 Then
If Len(c.Value) = 0 Then c.Value = Now 'value entered: add time
Else
c.ClearContents 'value cleared: clear time
End If
Next b
End If
If Not rngd Is Nothing Then
For Each d In rngd.Cells
Set e = d.Offset(0, 1)
If Len(d.Value) > 0 Then
If Len(e.Value) = 0 Then e.Value = Now 'value entered: add time
Else
e.ClearContents 'value cleared: clear time
End If
Next d
End If
End Sub
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
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