I am currently using the following VBA to run a macro when a value chosen from a dropdown changes, and the code works fine:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("D5")) Is Nothing Then
Select Case Range("D5")
Case "2008": Macro1
Case "2015": Macro1
End Select
End If
End Sub
However I would like to run the following event when another cell changes (also a drop down), the code is written to hide columns, this is the snippet of the additional code:
Sub hideColumnsBasedOnConditionZero()
LastColumn = 11 'Last Column
For i = 1 To LastColumn 'Lopping through each Column
'Hide all the columns with the values as 0 in Row 11
If Cells(1, i) = 0 And Cells(1, i) <> "" Then Columns(i).EntireColumn.Hidden = True
Next
End Sub
Can someone please tell me how to achieve this? The second code is valid but I cannot activate it as the first code is using the change function and is specific to another cell.
You can just add it to your first event
Private Sub Worksheet_Change(ByVal Target As Range)
Dim LastColumn As Long
With Me
If Not Intersect(Target, .Range("D5")) Is Nothing Then
Select Case .Range("D5")
Case "2008", "2015": Macro1
End Select
ElseIf Not Intersect(Target, .Range("Your Other Range")) Is Nothing Then
Call hideColumnsBasedOnConditionZero
End If
End With
End Sub
Related
I'm new to VBA so I'm probably making some beginner mistakes, please bare with me.
Here is the summary of my goal : I have several sheets in an Excel Workbook with the same structure. In each of those, I have a "Project Status" column with numbers ranging from 0 to 12. I'm trying to monitor a change in the column and, if the value of a cell changes, the row gets moved to the corresponding sheet and location.
My problem is that my code works but leaves an empty row where the row was cut. I tried adding
Target.EntireRow.Delete
but, if I add it before Insert the inserted row is empty, if I add it after it doesn't seem to do anything.
Here is a shorter version of my code, that I have in every sheet that is concerned by it :
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
On Error GoTo bm_Safe_Exit
Application.ScreenUpdating = False
If Target.Value = 0 Then
Target.EntireRow.Cut
IdeasUpcoming.Range("4:4").Insert
End If
If Target.Value = 1 Then
Target.EntireRow.Cut
IdeasUpcoming.Range("4:4").Insert
End If
If Target.Value = 2 Then
Target.EntireRow.Cut
Current.Range("STATUSNewProjects").Offset(1, 0).Insert
End If
If Target.Value = 3 Then
Target.EntireRow.Cut
Current.Range("STATUSAdvancedProjects").Offset(1, 0).Insert
End If
If Target.Value = 4 Then
Target.EntireRow.Cut
Completed.Range("STATUSFinished").Offset(1, 0).Insert
End If
If Target.Value = 5 Then
Target.EntireRow.Cut
Completed.Range("STATUSOld").Offset(1, 0).Insert
End If
End If
bm_Safe_Exit:
Application.ScreenUpdating = True
End Sub
How can I delete the row I'm cutting? I'm sure the If / End If for each cell value aren't optimal, is there a way to simplify this (considering this is shortened, in reality I have 13 values)?
Thank you a lot for your help.
You can use the range.copy logic like this - then you can delete the row afterwards:
With Target.EntireRow
.Copy IdeasUpcoming.cells(4,1)
.Delete xlShiftUp
End With
Regarding your multiple checks:
Maybe you can create a configuration array, which holds per index the target sheets range after that the row should be inserted
Dim arrTarget(1 to 15) as range
set arrTarget(1) = IdeasUpcoming.Cells(4,1)
...
set arrTarget(4) = Completed.Range("STATUSFinished")
Then you can use it like this - without Ifs:
'insert new row for row to be copied
arrTarget(Target.value).Offset(1).EntireRow.Insert xlShiftDown
With Target.EntireRow
.Copy arrTarget(Target.value).Offset(1)
.Delete xlShiftUp
End With
Furthermore you should have one generic copy routine in a normal module
Public sub moveRows(Target as range)
'define arrTarget
'do the copying
End sub
And then you call this generic routine from either all worksheet_change routines
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
moveRows target '-- this is where you call the generic sub
end if
End Sub
Or - if you have a sheetname logic to identify the relevant worksheets, e.g. data1, data2 etc. then you could use the workbook_SheetChange event (in the ThisWorkbook-module)
```vba
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Sh.Name Like "data*" Then
Dim KeyCells As Range
Set KeyCells = Range("A:A")
If Not Application.Intersect(KeyCells, Range(Target.Address)) Is Nothing Then
moveRows Target '-- this is where you call the generic sub
End If
End If
End Sub
In case you have to make changes to your move-routine or the worksheet_change event, you only have to make changes in one place :-). (DRY: Don't repeat yourself)
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 need help automatically changing cells containing a certain value whenever a specific cell on same row changes value.
E.g whenever a cell in B column changes = change TRUE to FALSE on that specific row.
My VBA knowledge is pretty much nonexistent and Im certainly a beginner.
Im fairly sure that Worksheet.Change is what Im looking for and I've been trying out some code I've found here on SO, such as:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Target.Parent.Range("B:B")) Is Nothing Then Exit Sub
For Each x In Target
Cells(x.Row, 3).Value = "False"
Next
End Sub
I know though that this doesn't replace specific values in whatever column the cells are.
I've been trying out silly things like:
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Target.Parent.Range("B:B")) Is Nothing Then Exit Sub
For Each x In Target
If Cells(x.Row, x.Column).Value = "TRUE" Then Value = "FALSE"
Next
End Sub
But of course it doesnt work.
Think you could point me out a direction of what I should be researching?
Replace the change event sub on the sheet where you have your data with the code below. I think that should do the trick
Private Sub Worksheet_Change(ByVal Target As Range)
Dim oRng As Range
Dim oCell As Range
' Check if change was in column B
If Intersect(Target, Target.Parent.Range("B:B")) Is Nothing Then Exit Sub
' Turn off events so that when we make a change on the sheet, this event is not triggered again
Application.EnableEvents = False
' Set the range to include all column in Target row
Set oRng = Target.Parent.Range("C" & Target.Row & ":" & Target.Parent.Cells(Target.Row, Target.Parent.UsedRange.Columns.Count).Address)
' Loop through all cells to change the value
For Each oCell In oRng
If Trim(LCase(oCell.Value)) = "true" Then
oCell.Value = "FALSE"
End If
Next
' Enable events again
Application.EnableEvents = True
End Sub
I want to activate a macro on a change in a range.
The following code works fine except I want a variable last row (Where B100 currently is).
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B1:B100")) Is Nothing Then
MsgBox "Updating sheets"
Call Thickborders2
End If
End Sub
The B100 in the range is dependent on the last row with text in it.
You can borrow a worksheet trick to find the last row with text in it.
=MATCH("zzz", B:B)
The above returns the last row in column B with a text value.
Private Sub Worksheet_Change(ByVal Target As Range)
dim m as variant
m = application.match("zzz", columns("B"))
if iserror(m) then m = 1
If Not Intersect(Target, Range("B1").resize(m, 1)) Is Nothing Then
MsgBox "Updating sheets"
Call Thickborders2
End If
End Sub
I strongly recommend adding error control (on error goto <label>) and disabling event triggers (application.enableevents = false). Remember to re-enable events before exiting the sub.
As I said in my comment on the OP - Worksheet_Change on its own won't work as it will calculate the last cell based on the data just entered.
This code calculates the last cell when you move cells (I tried on the Calculate event but that happens after you've added the data so same problem as the Change event).
Option Explicit
Private rLastCell As Range
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Set rLastCell = Cells(Rows.Count, 2).End(xlUp)
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range(Cells(1, 2), rLastCell)) Is Nothing Then
MsgBox "Updating sheets"
Call Thickborders2
End If
End Sub
The first two lines must be at the very top of the module.
Building on comments from Taazar and L42 try:
Private Sub Worksheet_Change(ByVal Target As Range)
LastCell = Activesheet.Usedrange.Rows.Count
If Not Intersect(Target, Range("B1:B" & LastCell)) Is Nothing Then
MsgBox "Updating sheets"
Call Thickborders2
End If
End Sub
Where Activesheet should be replaced by the sheetname you're checking.
I have a table of values that I need to fill out through a worksheet change function.
What I am trying to do is change a cell in columns B-G, depending on where the target is.
Private Sub Worksheet_Change(ByVal Target As Range)
If (Not Intersect(Target, Range(Cells(12, 2), Cells(14, 7))) Is Nothing) Then
Cells(16,Application.WorksheetFunction.Column(Target))="Hello"
End If
End Sub
I have similar bits of code in the same worksheet_change sub that work fine when I use Target.Offset(1,0) but since my possible target range is in more than 1 Row, I don't know how to make it so that it is always row 16 and the same column as the target....
You need to deal with situations where Target is more than a single cell and disable event handling so when you change a value on the worksheet, the Worksheet_Change doesn't try to run on top of itself.
This will put 'hello' into the cell immediately to the right of any cell within B:G that changes; essentially you would be adding 'hello' to columns C:H on the associated row of each cell in Target.
Private Sub Worksheet_Change(ByVal Target As Range)
if not intersect(target, Range(Cells(12, "B"), Cells(14, "G"))) is nothing then
on error goto safe_exit
application.enableevents = false
dim t as range
for each t in intersect(target, Range(Cells(12, "B"), Cells(14, "G")))
t.Offset(1,0) = "hello"
next t
End If
safe_exit:
application.enableevents = true
End Sub