I'm trying to make hyperlinks in the first column on the condition that value in the cell begins with 'W'.
It seemed to work until I moved the script from Sheet object to ThisWorkbook.
Since then when I try to copy some cells from another worksheet and paste them to active worksheet, everything what I copied is pasted as hyperlink, no matter what column or value it is. What's more, if I try to type anything in the row where the first cell is linked, the default typing mode is in the hyperlink style.
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim KeyCells2 As Range
Set KeyCells2 = Range("A:A")
If Not Application.Intersect(KeyCells2, Range(Target.Address)) _
Is Nothing Then
On Error Resume Next
If Target.Count = 1 Then 'this one was meant to be a fix but it didn't change a thing
If Left(Target.Value, 1) = "W" Then
link = "http://<mylink>" & Target.Value
ActiveSheet.Hyperlinks.Add Target, link
End If
End If
End If
End Sub
Try this, I think it will do what you need:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim KeyCells2 As Range
Dim targetcell As Range
Set KeyCells2 = Application.Intersect(Sh.Range("A:A"), Target, Sh.UsedRange)
If Not KeyCells2 Is Nothing Then
For Each targetcell In KeyCells2
If Left(targetcell.Value, 1) = "W" Then
link = "http://my.link." & targetcell.Value
Sh.Hyperlinks.Add Anchor:=targetcell, Address:=link
End If
Next
End If
End Sub
Related
I am trying to write macros code where, when the value of drop down under a column in table with header "Status", changes to "completed", then Sub Completedarc should run automatically. I am able to write a code when action status is changed to completed in one column but not the entire column in a table. Also,Sub Completedarc() is only cut pasting values in another sheet but not deleting the overcall row and it is left blank
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Range "Open_Project_Details[[#Headers],[Status]]") Then
Select Case Target.Value
Case "Completed"
Call Completedarc
End Select
End If
End Sub
Sub Completedarc()
Rows(ActiveCell.Row).EntireRow.Cut
Sheets("Completed Archive").Select
Range("Completed_Archive[[#Headers],[Stack Rank]]").Select
Selection.End(xlDown).Select
If ActiveCell = "" Then
ActiveSheet.Paste
Else
ActiveCell.Offset(1).Activate
ActiveSheet.Paste
End If
End Sub
If I well understood your question, this changed event will do what you need:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Target.ListObject Is Nothing Then
If Intersect(Target.ListObject.HeaderRowRange, _
Target.EntireColumn).value = "Status" Then
If Target.value = "Completed" Then
Call Completedarc(Target) 'added an argument...
End If
End If
End If
End Sub
About the Completedarc sub, I do not understand what is to be done. Does your "Open_Project_Details" table starts from column A:A and you want copying the table Target row in the first empty cell of the "Completed_Archive" table/column "Stack Rank"? Do you want to copy it inserting a new row after the table last one?
If this last one supposition is what you want, please use the next code:
Sub Completedarc(Target As Range)
Dim TRows As Long, shCA As Worksheet
Set shCA = Worksheets("Completed Archive")
TRows = shCA.Range("Completed_Archive[Stack Rank]").cells.count
If TRows = 1 Then TRows = TRows + 1
Intersect(Target.ListObject.DataBodyRange, Target.EntireRow).Copy _
shCA.Range("Completed_Archive[Stack Rank]").cells(TRows)
'the next code line only selects the row to be deleted. If it selects what you need
'you would only replace `Select` with `Delete` and the code will delete such rows
Target.EntireRow.Select 'Delete
End Sub
Cut/Paste Table Row on Cell Change
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
completeArchive Target
End Sub
Sub completeArchive(ByVal Target As Range)
If Target.Cells.CountLarge = 1 Then
Dim ws As Worksheet: Set ws = Target.Worksheet
Dim rg As Range
Set rg = Intersect(Target, ws.Range("Open_Project_Details[Status]"))
If Not rg Is Nothing Then
If rg.Value = "Completed" Then
Set rg = Intersect(ws.Rows(rg.Row), _
ws.Range("Open_Project_Details"))
With ws.Parent.Worksheets("Completed Archive")
With .Range("Completed_Archive[Stack Rank]")
rg.Copy .Cells(.Rows.Count + 1)
rg.Delete
End With
End With
End If
End If
End If
End Sub
I need to highlight and entire row if a cell string contains the word "risk". But I need to make it using vba since the person using it will write on it after using the macro.
I have something like:
The reason will be written afterwards and I need to highlight the row if someone writes the word risk anywhere in this column. Anything can be written there.
I use this to highlite a row when I want a full match:
lastReg= Cells(Rows.Count, 1).End(xlUp).Row
Set Rng = Range("A1:J" & lastReg)
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=$J1=""Plat"""
...
so I tried:
Rng.FormatConditions.Add Type:=xlExpression, Formula1:="=FIND(""risk"",$J1)>0"
But it doesn't work.
Edit: it gives me an execution error so the code itself doesn't run.
Edit2: Someone else uses this macro, and he can't do it by himself so I wanted the code to do it for him.
Also, the code is stored in the personal.xlsb because he runs the code in a different worksheet everyday, so I can't pre config the formatConditions for the worksheet.
I would use a worksheet change event. place this sub in your worksheet. Whenever any cell in column 5 changes and the value is "risk", it will color the row.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Rng As Range
Set Rng = Columns(5)
If Not Intersect(Rng, Target) Is Nothing And Target.Value = "risk" Then
Target.Offset(, -4).Resize(, 5).Interior.Color = vbYellow
End If
End Sub
Try:
Option Explicit
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim cell As Range
If Not Intersect(Target, Sh.UsedRange) Is Nothing Then
For Each cell In Target.Cells
With cell
If UCase(.Value) = "RISK" Then
.Font.Color = vbRed
Else
.Font.Color = vbBlack
End If
End With
Next cell
End If
End Sub
I have a table of customer data in Excel that can be added/edited using a VBA userform. Therefore I would like to highlight the row that has just been added/edited. This is my first time using VBA so I searched and found code from here:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Value <> "" Then
Target.Interior.ColorIndex = 6
End If
End Sub
which works perfectly fine but the highlights for the previous edits/add-ons are still there. I just want the last one to be highlighted.
Use a variable. Store the range in that when you are changing the color. Next time remove the color from that range.
Is this what you are trying?
Dim prevRng As Range
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim aCell As Range
If Not prevRng Is Nothing Then prevRng.Interior.ColorIndex = xlNone
Set prevRng = Target
For Each aCell In Target
If aCell.Value <> "" Then aCell.Interior.ColorIndex = 6
Next aCell
End Sub
This will handle multiple cells as #Pᴇʜ mentioned in the comment.
Here is some code that could work for you:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
'Removing old conditional formatting if it exists already
Conditions = ActiveSheet.Cells.FormatConditions.Count
For i = 1 to Conditions
If ActiveSheet.Cells.FormatConditions(i).Type = 2 Then
If ActiveSheet.Cells.FormatConditions(i).Formula1 = "=1" Then ActiveSheet.Cells.FormatConditions(i).Delete
End If
Next i
'Adding new conditional formatting rule to the edited range
Target.EntireRow.FormatConditions.Add Type:=xlExpression, Formula1:="=1"
Target.EntireRow.FormatConditions(1).Interior.ColorIndex = 6
End Sub
Currently it will highlight all the last edited rows in all sheets. Not sure if this is what you wanted.
It will keep colored cells in your sheet intact when a new range has been changed.
It will keep other conditional formatting rules intact.
It highlights the last edited range, even if the range has been cleared!
I try to write a macro that on double click of a cell, inserts a new row below that cell with some formulas. The important thing for me is that if I double click the cell again, then the formulas of the previously inserted line are updated with the right indexes.
For example, in the code below, double click A1 will insert the formula =B2+1 in line 2. Double clicking again should insert the same in line 2. But now line 2 shifter to line 3, so the formula in A3 should be =B3+1.
Here is the code I have so far:
Option Explicit
Const MYRANGE As String = "A:A"
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'If Sh.Name <> "Sheet1" Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Sh.Range(MYRANGE)) Is Nothing Then Exit Sub
Cancel = True
Target.Rows(2).Insert
Dim newRow As Range
Set newRow = Target.Rows(2)
Dim rowIndex As Long
rowIndex = newRow.row
newRow.Cells(1, 1).Formula = "=B" & rowIndex & "+1"
End Sub
UPDATE: Changing Target.Rows(2).Insert to Target.Offset(1).EntireRow.Insert solves the issue. Leaving the question open for explanations on what is Offset and how it differs from Rows (The property EntireRow does not exist for Rows(2))
You can reduce this code by four lines for the same outcome, pls see below
Note though that your code is updating cells in your target row and below, ie it won't be updating any cell formulae outside column A that reside above your target. Which is probably not an issue but worth mentioning. If you wanted a full update then you would always insert at row2 rather than at target
Option Explicit
Const MYRANGE As String = "A:A"
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
If Target.Cells.Count > 1 Then Exit Sub
If Intersect(Target, Sh.Range(MYRANGE)) Is Nothing Then Exit Sub
Cancel = True
Target.Offset(1).EntireRow.Insert
Target.Offset(1).Formula = "=B" & Target.Row + 1 & "+1"
End Sub
Ran in to a little problem. If I try to paste to multiple cells that are in the range in the code below, I get a run time error 13, type mismatch. The cells in the range may have data other than X but I only want the hyperlink to appear if the cell contains X. It works fine if I just type an X in the cell or if I paste to one cell at a time. I will have times when I want to paste other text to mutiple cells in this range. Thanks to Remnant for his help on the original code. This one last hurdle will put me in the clear. Thx.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rangeLimit As Range
Set rangeLimit = Range
("B9:B37,C9:C37,D9:D37,E9:E37,F9:F37,G9:G37,H9:H37,I9:I37,J9:J37,K9:K37,L9:L37,M9:M37")
If Not Intersect(rangeLimit, Target) Is Nothing Then
If Target = "x" Or Target = "X" Then
Target.Hyperlinks.Add Anchor:=Target, Address:="", SubAddress:="Exceptions!A1",
TextToDisplay:=Target.Value
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rangeLimit As Range
dim c as range
Set rangeLimit = Range("B9:M37")
If Not Intersect(rangeLimit, Target) Is Nothing Then
for each c in Intersect(rangeLimit, Target)
If c.value = "x" Then
c.Hyperlinks.Add Anchor:=c, Address:="", SubAddress:="Exceptions!A1", TextToDisplay:=c.Value
End If
next c
End If
End Sub
When you paste in a range, 'Target' is a set of cells - not just one cell. If you know this code works for one cell, you can loop over all of the cells in the range target, and call the If statement on each of the cells.
Try this modification to the original code.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rangeLimit As Range
Dim cl As Range
Set rangeLimit = Range("B9:B37,C9:C37,D9:D37,E9:E37,F9:F37,G9:G37,H9:H37,I9:I37,J9:J37,K9:K37,L9:L37,M9:M37")
If Not Intersect(rangeLimit, Target) Is Nothing Then
For Each cl In Target
If cl = "x" Or cl = "X" Then
cl.Hyperlinks.Add Anchor:=cl, Address:="", SubAddress:="Exceptions!A1", TextToDisplay:=cl.Value
End If
Next cl
End If
End Sub