I thought this was cool when I figured it out and would share.
The code removes the need to add "=" signs in front of formulas. This can give your excel sheet more of a software feel when creating templates designed for calculations to be made frequently.
In my case I have a financial analysis template that requires you have to add many items together in many different cells and much of our other templates are not excel based and do not require the "=" which causes aggravation for users switching between the two.
Private Sub Worksheet_Change(ByVal Target As Range)
'Trigger Macro
If Target.Cells.Count > 0 Then
'Define Variables
Dim rng As Range
Dim cell As Range
Dim x As String
Set rng = Target
'Add equal sign to all updated cells
On Error GoTo NoFormulas
If rng = "" Then
Exit Sub
On Error GoTo 0
ElseIf rng = Range("C2") Then
Exit Sub
Else
For Each cell In rng
On Error GoTo NoFormulas
x = cell.Formula
cell = "=" & Right(x, Len(x))
On Error GoTo 0
Next cell
Exit Sub
End If
End If
'Error Handler
NoFormulas:
Exit Sub
End Sub
Related
I am newbie at excel and VBA so I came here to ask for your help.
I am looking for a VBA code to automatically color the first letter of each column cell.This is expected for column A only, not all columns in excel.
There are only words in the column.
For example, if the first letter is 'a' then the 'a' only will become red.There is no limit of case-sensitive and each of a-z will be colored in 26 distinguishable colors. I tried for a couple of days to find a solution, but unfortunately I couldn't.
Demonstration:
Thanks in advance.
There’s (at least) a couple of ways to do this. The first option below selects the color for you – you don’t get a choice, but the code is much shorter. The second option will require you to hard code the actual color you want for each letter – I’ve only gone as far as C for the sake of demonstration.
In both cases, you paste the code into the Sheet module area for the appropriate sheet. Let me know how it goes for you. I've taken this approach because you said you wanted it to occur "automatically"
Option One – shorter but no choice of color
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo GetOut
Application.EnableEvents = False
Dim myFont As Integer, aCell As Range
For Each aCell In Target.Cells
myFont = Asc(UCase(Left(aCell, 1))) - 62
aCell.Characters(Start:=1, Length:=1).Font.ColorIndex = myFont
Next
Continue:
Application.EnableEvents = True
Exit Sub
GetOut:
MsgBox Err.Description
Resume Continue
End Sub
Option Two – you choose the color you want, but must be added
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo GetOut
Application.EnableEvents = False
Dim myLetter As String, aCell As Range
For Each aCell In Target.Cells
myLetter = UCase(Left(aCell, 1))
Select Case myLetter
Case Is = "A"
aCell.Characters(Start:=1, Length:=1).Font.ColorIndex = 3 `<~~ change to your taste
Case Is = "B"
aCell.Characters(Start:=1, Length:=1).Font.ColorIndex = 4
Case Is = "C"
aCell.Characters(Start:=1, Length:=1).Font.ColorIndex = 5
'*** etc etc etc Add the rest of the alphabet***
End Select
Next
Continue:
Application.EnableEvents = True
Exit Sub
GetOut:
MsgBox Err.Description
Resume Continue
End Sub
To apply this to any (or certian) worksheets in the Workbook containing the code, place this code in the ThisWorkbook module
Option Explicit
Private Colours As Variant
' Define Colour Pallete
Private Sub PopulateColours()
ReDim Colours(0 To 25)
Colours(0) = vbRed 'A
Colours(1) = vbBlue 'B
' etc C..Z
End Sub
' Colour first character of each non-formula cell in range
Private Sub ColourCells(rng As Range)
Dim cl As Range
' if pallet not set, initialise it
If IsEmpty(Colours) Then PopulateColours
' loop the range
For Each cl In rng
' ignore formula, numeric and empty cells
If Not IsEmpty(cl) Then
If Not cl.HasFormula Then
If Not IsNumeric(cl.Value2) Then
If Not cl.Value2 = "" Then
With cl.Characters(1, 1)
.Font.Color = Colours(Asc(UCase(.Text)) - 65)
End With
End If
End If
End If
End If
Next
End Sub
' when and cell on any worksheet in the workbook changes...
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' select specific sheets to apply colour to
Select Case Sh.Name
Case "Sheet1", "Sheet2"
' only colour column A
If Not Application.Intersect(Target, Sh.Columns(1)) Is Nothing Then
' call colouring routine
ColourCells Target.Columns(1)
End If
End Select
End Sub
If you want to apply this to any (or certain) open workbooks, you'll need an Application Events handler
I am using a VBA change event to look for duplicates in column C. The code below works but when i delete all values within the range, blanks are triggered as duplicates so i need to include a way to ignore duplicates from the code. Any ideas?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
On Error GoTo ws_exit
Application.EnableEvents = False
With Target
If .Column = 3 Then
With .EntireColumn
Set cell = .Find(What:=Target.Value, AFter:=.Cells(1, 1))
If cell.Address = Target.Address Then
Set cell = .FindNext()
End If
If Not cell.Address = Target.Address Then
MsgBox "This Wall Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly
End If
End With
End If
End With
ws_exit:
Application.EnableEvents = True
End Sub
I expect to be able to ignore blanks but sill have the VBA run a duplication check to return a msgbox only if a duplication is found.
First you must consider that Target is a range of multiple cells and not only one cell. Therefore it is necessary to use Intersect to get all the cell that are changed in column 3 and then you need to loop through these cells to check each of them.
Also I recommend to use WorksheetFunction.CountIf to count how often this value occurs if it is >1 then it is a duplicate. This should be faster then using Find.
Note that the following code looks for duplicates in column 3 only if you want to check if a duplicate exists anywhere in the worksheet replace CountIf(Me.Columns(3), Cell.Value) with CountIf(Me.Cells, Cell.Value)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim AffectedRange As Range
Set AffectedRange = Intersect(Target, Me.Columns(3))
If Not AffectedRange Is Nothing Then
Dim Cell As Range
For Each Cell In AffectedRange
If Application.WorksheetFunction.CountIf(Me.Columns(3), Cell.Value) > 1 Then
MsgBox "This Wall Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly + vbExclamation
End If
Next Cell
End If
End Sub
Instead of using VBA you could also use Conditional Formatting to highlight duplicates in red for example. Could be easier to archieve (use the =CountIf formula as condition). And also it will always highlight all duplicates immediately which makes it easy to determine them.
Thanks for the help K.Davis. I appreciate your time and effort.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Value = vbNullString Then Exit Sub
Dim cell As Range
On Error GoTo ws_exit
Application.EnableEvents = False
With Target
If .Column = 3 Then
With .EntireColumn
Set cell = .Find(What:=Target.Value, AFter:=.Cells(1, 1))
If cell.Address = Target.Address Then
Set cell = .FindNext()
End If
If Not cell.Address = Target.Address Then
MsgBox "This Glazing Reference already exists. Please ensure you have a unique reference identifier less than 20 characters in length", vbOKOnly
End If
End With
End If
End With
ws_exit:
Application.EnableEvents = True
End Sub
First question: I want to run a macro automatically when a specific cell value changes, however when the cell value changes, it doesn't run. The only way it runs is when I go to the "Macros" section under the developer tab and manually run the macro.
Second Question: I have a cell that is formatted as text and displays "somenumber% / someothernumber%" and I want the negative values to be colored red and the positive values to colored green. The problem is it only registers the first value, so if it's positive then all of the cell values are green, and vice versa for negative. Here is the specific text formatting: = TEXT(AS4,"[>0]+#,###0.000%;[<0]-#,###0.000%")&" "&"/"&" "&TEXT(AS6,"[>0]+#,###0.000%;[<0]-#,###0.000%").
Here is my attempt at both solutions:
Sub TextColorChange()
Dim xWs As Worksheet
Set xWs = Sheets("Trading Statistics")
For Row = 10 To 13
vall = xWs.Cells(Row, 51).Value
CheckPlus = InStr(1, vall, "+")
CheckMinus = InStr(1, vall, "-")
CheckDash = InStr(1, vall, "/")
part = Len(vall) - CheckDash + 1
If CheckMinus <> 0 Then
xWs.Cells(Row, 51).Characters(Start:=CheckMinus, Length:=part).Font.ColorIndex = 3
End If
If CheckPlus <> 0 Then
xWs.Cells(Row, 51).Characters(Start:=CheckPlus, Length:=part).Font.ColorIndex = 10
End If
Next Row
End Sub
--------------------------------
Private Sub Worksheet_Calculate()
Dim Xrg As Range
Set Xrg = Me.Range("AY6")
If Not Intersect(Xrg, Me.Range("AY6")) Is Nothing Then
Call TextColorChange
End If
End Sub
I have an excel file that does this, the code I use to active my macro when a user paste data in a sheet is:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A2")
If Not Application.Intersect(KeyCells, Range(Target.Address)) _
Is Nothing Then
Call Sorting
Call Pic
End If
MsgBox "Data updated"
End Sub
Sorting and Pic are the macros being called and the above code has to be put in the actual sheet where the macro should trigger (i.e not in the module)
EDIT: this answers your first question. Please mark it as helpful if it was, then post your second question in a new post altogether.
What I'm trying to do is when a cell (A1) matches something in a named range ("Names") then it changes colour, however if it doesn't but matches something a different named range ("Eye") then it becomes a different colour (there are many more ranges, but I'm sure I'll be able to figure it out after I have two working)
Things to note:
I know this can be done with conditional formatting, however due to the number of named ranges, and sizes of the ranges I was hoping it would be easier using a macro.
I so far have managed to get it working for one named range, and when A1 isn't a formula (however A1 will be)
My 2 lots of code so far are (note this is under sheet1):
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
Application.Run ("Colour")
End If
End Sub
The my second one (is being a seperate module):
Sub Colour()
With ActiveSheet
For Each c In .Range("Names").Cells
If c.Value = .Range("A1").Value Then
Range("A1").Select
With Selection.Interior
.Color = 5287936
End With
End If
Next c
End With
End Sub
I think this does what you want:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Range("A1")) Is Nothing Then
ApplyColor Me.Range("A1")
End If
End Sub
Sub ApplyColor(ValueRange As Range)
Dim MatchRanges As Variant
Dim MatchColors As Variant
Dim MatchValue As Variant
Dim i As Long
MatchRanges = Array("Names", "Eye")
MatchColors = Array(5287936, 4287952)
MatchValue = ValueRange.Value
ValueRange.Interior.Color = vbWhite
For i = LBound(MatchRanges) To UBound(MatchRanges)
If WorksheetFunction.CountIf(Me.Range(MatchRanges(i)), MatchValue) > 0 Then
ValueRange.Interior.Color = MatchColors(i)
Exit For
End If
Next i
End Sub
A couple of notes: "Color" is a VBA reserved word and could cause issues, so I used something else for your sub name. You don't need to use Application.Run in this situation, just the sub's name and its arguments (or Call if you prefer).
I am attempting to create a drop-down list populated with a range from another sheet. But what I want to do is show the full list, and when the user selects and item, it will only enter into that cell all characters before the dash.
So, if I had "David - Project Manager" upon selection the cell with populate with just "David" and remove everything after the dash. Everything after is just there to make things easier to see.
You can't do this with Data Validation. VBA could be used to modify the validated cell (but that would break the validation, wouldn't it?) How about a compromise where Data Validation provides the full entry, then an adjacent cell trims it down to your requirement, which I believe is:
=IFERROR(TRIM(LEFT(A1,SEARCH("-",A1)-1)),A1)
Where A1 is a cell containing Data Validation
The VBA method doesn't break the validation since VBA can go around those requirements. Assuming the range of cells with the DV to adjust is B2:B100, try this:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim cell As Range
If Not Intersect(Target, Range("B2:B100")) Is Nothing Then
For Each cell In Intersect(Target, Range("B2:B100"))
If InStr(1, cell.Value, "-") > 0 Then
Application.EnableEvents = False
cell.Value = Trim(Left(cell.Value, InStr(1, cell.Value, "-") - 1))
Application.EnableEvents = True
End If
Next cell
End If
End Sub
That macro goes into the SHEET module.
I found the answer in a Contextures Video.
There is a link to the code needed on the sheet in a downloadable XLS file.
Option Explicit
' Developed by Contextures Inc.
' www.contextures.com
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo errHandler
If Target.Cells.Count > 1 Then GoTo exitHandler
If Target.Column = 6 Then
If Target.Value = "" Then GoTo exitHandler
Application.EnableEvents = False
Target.Value = Worksheets("codes").Range("C1").Offset(Application.WorksheetFunction.Match(Target.Value, Worksheets("codes").Range("activitycodes"), 0) - 1, -2)
End If
exitHandler:
Application.EnableEvents = True
Exit Sub
errHandler:
If Err.Number = 13 Or Err.Number = 1004 Then
GoTo exitHandler
Else
Resume Next
End If
End Sub