I am trying to hide/unhide rows based on specific cell values. So far my code works and is below:
However, I am also trying to show rows between the "yes" "no" rows. for instance, row 11-15 begins as shown. Row 15 has "yes" or "no" answers. After choosing "yes", I need to show 16-20. but as of now, I can only show 20 (column 8 is the selection for yes/no and column 11 is the offset and column 12 currently contains the number to skip to... so row 15 column 12 contains "20"... but I need it to be 16-20). How do I solve this? Thank you
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then
For Each cel In Target
Call Worksheet_Change(cel)
Next cel
End If
If Target.Column = 8 Then
If LCase(Target.Value) = LCase(Target.Offset(, 3)) Then
Cells(Target.Offset(, 4), 1).EntireRow.Hidden = False
Else
Cells(Target.Offset(, 4), 1).EntireRow.Hidden = True
End If: End If
End Sub
The easiest way to do this is to using a loop. What you want to do is hide each row in a loop, for example this loop will hide Rows 1-3
For i=1 to 3
Rows(i).EntireRow.Hidden = True
Next
If I understnad your setup correctly column 8 contains "yes/no". Column 11 contains a row offset to start (un)hiding rows. Column 12 tells where to stop (un)hiding rows.
I will use the following notation to indicate a cell address (row, column)
Back to your example if (15,8) says "yes" then you unhide rows 16,17,18,19,20. This means (15,11) would contain 1 since the offset to get to row 16 is the current_row + 1, where current row is 15 cell (15,12) contains 20 since it is the last row to skip to. Simply use the value from cell (15,11) as the start of your loop and the value in cell (15,12) as the stop value
Private Sub Worksheet_Change(ByVal Target As Range)
'defines some constants
Const iYES_NO_COL = 8
Const iOFFSET_COL = 11
Const iSKIP_TO_COL = 12
If Target.Count > 1 Then
For Each cel In Target
Call Worksheet_Change(cel)
Next cel
End If
ElseIf Target.Count = 1 Then
'im not sure what this does so i left it
If Target.Column = 8 Then
If LCase(Target.Value) = LCase(Target.Offset(, 3)) Then
Cells(Target.Offset(, 4), 1).EntireRow.Hidden = False
Else
Cells(Target.Offset(, 4), 1).EntireRow.Hidden = True
End If
If (Target.Column = iYES_NO_COL) Then
' takes the current row + the value in the offset cell
my_start = Target.Row + Cells(Target.Row, iOFFSET_COL).Value
' takes the value from the SKIP_TO_COL
my_stop = Cells(Target.Row, iSKIP_TO_COL).Value
'target should be only one cell at this point, see if it
'contains the word no
If (StrComp(Trim(LCase(Target.Value)), "no") = 0) Then
'hides all the rows between the start and stop value
For i = my_start To mystop
Rows(i).EntireRow.Hidden = True
Next
ElseIf (StrComp(Trim(LCase(Target.Value)), "yes") = 0) Then
'unhides all the rows between the start and stop value
For i = my_start To mystop
Rows(i).EntireRow.Hidden = False
Next
End If
End If
End Sub
Related
Skip my rambling narrative by scrolling down to tldr and Question.
I have several rows and columns with values; e.g. A10:G15. In each row, the value of the cell immediately to the right of any cell is dependent on that cell up to the extents of the columns involved. In this manner, the value of a cell immediately to the right of any cell is always numerically larger than the cell or blank if the original cell is blank.
To maintain this dependency, I want to clear any values to the right if I clear the value from a cell within A:F or progressively add a random number to the remaining cells to the right if I input a new value into any cell within A:F.
Sample data. The 7 in the top-left is A10.
A B C D E F G
7 12 15 19 23 27 28
4 6 10 14 17 18 22
8 10 14 18 23 26 31
8 13 15 18 22 25 30
8 13 16 18 19 21 24
0 3 4 9 10 12 16
'similar data in A19:G22 and A26:G30
tldr
▪ If I clear D12, E12:G12 should also be cleared.
▪ If I type a new value into C14 then D14:G14 should each receive a new value which is random but larger than the previous value.
▪ I might want to clear or paste in several values in a column and would expect the routine to deal with each in turn.
▪ I have several of these non-contiguous regions (see Union'ed range in code sample below) and would prefer a DRY coding style.
Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'Debug.Print Target.Address(0, 0)
If Not Intersect(Target, Range("A10:F15, A19:F22, A26:F30")) Is Nothing Then
Dim t As Range
For Each t In Intersect(Target, Range("A10:F15, A19:F22, A26:F30"))
If IsEmpty(t) Then
t.Offset(0, 1).ClearContents
ElseIf Not IsNumeric(t) Then
t.ClearContents
Else
If t.Column > 1 Then
If t <= t.Offset(0, -1) Or IsEmpty(t.Offset(0, -1)) Then
t.ClearContents
Else
t.Offset(0, 1) = t + Application.RandBetween(1, 5)
End If
Else
t.Offset(0, 1) = t + Application.RandBetween(1, 5)
End If
End If
Next t
End If
End Sub
Code explanation
This event driven Worksheet_Change deals with each cell that has changed but only modifies the cell directly to the right, not the remaining cells in that row. The job of maintaining the remaining cells is achieved by leaving event triggers active so that when that single cell to the right is modified, the Worksheet_Change triggers an event that calls itself with a new Target.
Question
The above routine seems to run fine and I have yet to destabilize my project environment despite my best/worst efforts. So what's wrong with intentionally running a Worksheet_Change on top of itself if the reiteration cycles can be controlled to a finite result?
I would argue that what is wrong with recursively triggering the change event is that this way Excel can only sustain a pretty tiny call stack. At 80 calls it killed my Excel instance. When I outsourced the recursion I at least got to a little over 1200 calls, of course adding redundancy to some extent:
Option Explicit
Const RANGE_STR As String = "A10:F15, A19:F22, A26:F30"
Private Sub Worksheet_Change(ByVal target As Range)
Application.EnableEvents = False
Dim t As Range
If Not Intersect(target, Range(RANGE_STR)) Is Nothing Then
For Each t In Intersect(target, Range(RANGE_STR))
makeChange t
Next t
End If
Application.EnableEvents = True
End Sub
Sub makeChange(ByVal t As Range)
If Not Intersect(t, Range(RANGE_STR)) Is Nothing Then
If IsEmpty(t) Then
t.Offset(0, 1).ClearContents
makeChange t.Offset(0, 1)
ElseIf Not IsNumeric(t) Then
t.ClearContents
makeChange t
Else
If t.Column > 1 Then
If t <= t.Offset(0, -1) Or IsEmpty(t.Offset(0, -1)) Then
t.ClearContents
makeChange t
Else
t.Offset(0, 1) = t + Application.RandBetween(1, 5)
makeChange t.Offset(0, 1)
End If
Else
t.Offset(0, 1) = t + Application.RandBetween(1, 5)
makeChange t.Offset(0, 1)
End If
End If
End If
End Sub
I don't think you need recursive calls, read by area, by row, into array, change array and write back to sheet:
Const RANGE_STR As String = "A10:F15, A19:F22, A26:F30"
Private Sub Worksheet_Change(ByVal Target As Range)
Dim MyArr As Variant, TargetR As Long, TargetC As Long, i As Long, ar As Range, myRow As Range
Dim minC As Long, maxC As Long
If Not Intersect(Target, Range(RANGE_STR)) Is Nothing Then
minC = Range(RANGE_STR).Column 'taken form first area
maxC = 1 + Range(RANGE_STR).Columns.Count 'taken form first area
For Each ar In Target.Areas
TargetC = ar.Column
For Each myRow In ar.Rows
TargetR = myRow.Row
MyArr = Range(Cells(TargetR, minC), Cells(TargetR, maxC))
If IsEmpty(MyArr(1, TargetC)) Or Not IsNumeric(MyArr(1, TargetC)) Then
For i = TargetC To UBound(MyArr, 2)
MyArr(1, i) = Empty
Next i
Else
For i = TargetC + 1 To UBound(MyArr, 2)
MyArr(1, i) = MyArr(1, i - 1) + Application.RandBetween(1, 5)
Next i
End If
If Not Intersect(Range(Cells(TargetR, minC), Cells(TargetR, maxC)), Range(RANGE_STR)) Is Nothing Then
Application.EnableEvents = False
Range(Cells(TargetR, minC), Cells(TargetR, maxC)) = MyArr
Application.EnableEvents = True
End If
Next myRow
Next ar
End If
End Sub
Here you go the two subroutines of which I would like to sum up their value in the same cell.
Sub CheckBox126_Click()
If (Count = Null) Then
Count = 0
End If
Count = 0
If ActiveSheet.Shapes("Check Box 126").ControlFormat = xlOn Then Count = Count + 2
Range("C29").Value = Count
End Sub
'second routine
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C29")) Is Nothing Then
If Target.Value = "Orange" Then
Target.Offset(0, 1).Value = 1
ElseIf Target.Value = "Dark orange/brown" Then
Target.Offset(0, 1).Value = 1
ElseIf Target.Value = "Pink" Then
Target.Offset(0, 1).Value = 2
ElseIf Target.Value = "Red" Then
Target.Offset(0, 1).Value = 2
ElseIf Target.Value <> "" Then
Target.Offset(0, 1).Value = 0
Else
End If
End If
End Sub
I would like combine their value in the same cell. Please can you help me with this. Many thanks
Create a function like this:
Function CheckBox126() As Integer
If ActiveSheet.Shapes("Check Box 126").ControlFormat = xlOn Then
CheckBox126 = 2
else
CheckBox126 = 0
End If
End Function
At the end of your second procedure add:
Target.Offset(0, 1).Value = Target.Offset(0, 1).Value + CheckBox126()
The function will check the status of checkbox126, returning 2 or 0 and the second procedure adds this value on at the end.
So this is confusing. Someone checks a checkbox, then you check the value of Count, and set it to 0 if the condition is met. Then you set it to 0 anyway.
If the checkbox was ticked, its set to 2, if unticked, it stays as 0.
Then you set a cell to be the value of count, which will trigger Worksheet_Change, which it looks like you tried to set up so it will only trigger on a change to the cell that you changed above, so why not add it to the same subroutine?
Then you assume that the changed target is a single cell, and check its value for a color value. But as we know that if it is a single cell, to get to this point, that single cell has to be C29, the cell you changed to either 0 or 2 above, then we know the the value is the same as the value of count, so none of these conditions will ever match...
...Unless the cell C29 is change manually to a color, but in that case, you don't have 2 numbers to add.
I would suggest relooking at all of your code and rephrasing this question.
To actually answer your question, just add this to the bottom of the second routine:
Target.Offset(0, 1).Value = Target.Offset(0, 1).Value + Range("C29").Value
I wrote a macro to check the value being entered in some cells.
If the input is higher than 8 the excess is written to another cell and the input is changed to 8. If the input is lower than 8 the missing amount is written to a third cell.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
TA = Target.Address: R = Target.Row: C = Target.Column
If C = 2 Or C = 7 Then
If (R < 19 And R > 11) Or (R < 33 And R > 25) Then
Hours = Cells(R, C).Value
If Hours <> 0 Then
If Hours > 8 Then
Cells(R, C) = 8
Cells(R, C + 1) = Hours - 8
End If
If Hours < 8 Then
Cells(R, C + 2) = 8 - Hours
End If
End If
End If
End If
End Sub
The problem is the macro is not executed when I enter the input, only when I select the cell again.
First change your trigger event from Worksheet_SelectionChange to Worksheet_Change.
Second, you can optimize your code, since you can read the Column and Row property of Target, you can save a few rows in your code.
Third, I modified your test condition for checking the row, by switching to Select Case you can now add more rows to this condition easily.
Use Target.offset to insert the result in the neighbour cells.
I added Exit Sub so it won't run an extra time after you change the values here.
If you want, you can also remove the Hours as it is not needed (unless you have a global variable that somehow reads this value).
You can just use If Target.Value <> 0 Then etc.)
Private Sub Worksheet_Change(ByVal Target As Range)
' check if target is in Column B or Column G
If Target.Column = 2 Or Target.Column = 7 Then
Select Case Target.Row
Case 12 To 18, 26 To 32 ' check if target row is 12 to 18 (including) ir between 26 to 32 (including)
Hours = Target.Value
If Hours <> 0 Then
If Hours > 8 Then
Target.Value = 8
Target.Offset(0, 1).Value = Hours - 8
Exit Sub
Else
If Hours < 8 Then
Target.Offset(0, 2).Value = 8 - Hours
End If
Exit Sub
End If
End If
End Select
End If
End Sub
Your function Worksheet_SelectionChange only fires when the selected cell is changed. You should use Worksheet_Change instead. You can see this automatically execute an Excel macro on a cell change for more details.
It's been 6 years since I've worked with Excel and i'm a little bit rusty. Here's my scenario:
I am exporting a list of issues to Excel. I need to be able differentiate the associated Link numbers in a cell (mulitple values) from each other. Example, i have two columns,
Key = the number for a ticket
Linked Issues = The Keys associated
I need a statement that would scan the Key column and find a match in the Linked Issues column. Then once the match is found the matching text will assume the font color of the Key.
Where this get complicated is each cell of the Linked Issues column could look something like this iss-3913, iss-3923, iss-1649. So essentially the scan would be for a match within the string. Any help is appreciated.
I am sorry, I don't have time to finish this right now, but wWould something like this help with maybe a loop for each cell in the first column?
Edit: Finished now, second edit to update to B5 and Z5, edit 3 fixed goof with column reference and updated to use variables to assign what column to look in.
Sub colortext()
start_row = 5
key_col = 2
linked_col = 26
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
o = start_row 'start with row one for second column
Do While Not IsEmpty(Cells(o, linked_col)) 'Do until empty cell
If Not InStr(1, Cells(o, linked_col), Cells(i, key_col)) = 0 Then 'if cell contents found in cell
With Cells(o, linked_col).Characters(Start:=InStr(1, Cells(o, linked_col), Cells(i, key_col)), Length:=Len(Cells(i, key_col))).Font
.Color = Cells(i, key_col).Font.Color 'change color of this part of the cell
End With
End If
o = o + 1 'increment the cell in second column
Loop
i = i + 1 'increment the cell in the first column
Loop
End Sub
or maybe
Something like this?
Excel VBA: change font color for specific char in a cell range
This is an old post but I thought I would provide my work around to the conditional formating issue I was having.
Sub colorkey()
start_row = 5
key_col = 2
flag_col = 4
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
Tval = Cells(i, flag_col).Value
Select Case Tval
Case "Requirement"
'cval = green
cVal = 10
Case "New Feature"
'cval = orange
cVal = 46
Case "Test"
'cval = lt blue
cVal = 28
Case "Epic"
'cval = maroon
cVal = 30
Case "Story"
'cval = dk blue
cVal = 49
Case "Theme"
'cval = grey
cVal = 48
Case "Bug"
'cval = red
cVal = 3
Case "NOT MAPPED"
'cval = Maroon
cVal = 1
End Select
Cells(i, key_col).Font.ColorIndex = cVal
i = i + 1 'increment the cell in the first column
Loop
End Sub
Sub colorlinked()
start_row = 5
key_col = 2
linked_col = 26
i = start_row 'start on row one
Do While Not IsEmpty(Cells(i, key_col)) 'Do until empty cell
o = start_row 'start with row one for second column
Do While Not IsEmpty(Cells(o, linked_col)) 'Do until empty cell
If Not InStr(1, Cells(o, linked_col), Cells(i, key_col)) = 0 Then 'if cell contents found in cell
With Cells(o, linked_col).Characters(Start:=InStr(1, Cells(o, linked_col), Cells(i, key_col)), Length:=Len(Cells(i, key_col))).Font
.Color = Cells(i, key_col).Font.Color 'change color of this part of the cell
End With
End If
o = o + 1 'increment the cell in second column
Loop
i = i + 1 'increment the cell in the first column
Loop
MsgBox "Finished Scanning"
End Sub
I need to Loop the formula below until Column "B" which contains dates is empty.
I am stuck and I just can't seem to write the VBA Code to do the Loop until there is no more Dates in Column "B". The formula is smoothing out the yields by using those dates that have a yield.
I hope anyone would be able to help me. Thanks in advance
A B C D
5 Factor Date Yield Input
6 3 May-10 .25
7 1 Jun-10
8 2 Jul-10
9 3 Aug-10 0.2000
10 1 Sep-10
11 2 Oct-10
12 3 Nov-10 0.2418
13 1 Dec-10
14 2 Jan-11
15 3 Feb-11 0.3156
16 1 Mar-11
17 2 Apr-11
Sub IsNumeric()
' IF(ISNUMBER(C6),C6,
If Application.IsNumber(range("c6").Value) Then
range("d6").Value = range("c6")
' IF(C6<C5,((OFFSET(C6,2,0)-OFFSET(C6,-1,0))*A6/3+OFFSET(C6,-1,0)),
If range("c6").Select < range("c5").Select Then
range("d6").Value = range("c6").Offset(2, 0).Select - range("c6").Offset(-1, 0).Select * (range("a6").Select / 3) + range("c6").Offset(-1, 0).Select
' IF(C6<>C7,((OFFSET(C6,1,0)-OFFSET(C6,-2,0))*(A6/3)+OFFSET(C6,-2,0)),"")))
If range("c6").Select <> range("c7").Select Then
range("d6").Value = (range("c6").Offset(1, 0).Select) - range("c6").Offset(-2, 0).Select * (range("a6").Select / 3) + range("c6").Offset(-2, 0).Select
Else
range("d6").Value = ""
End If
End If
End If
End Sub
Sub Test01()
Dim m, r, cell As Object
Dim n As Boolean
Set m = Sheets("Sheet1").Cells(1, 2)
Do
Set m = m.Offset(1, 0)
Set r = m.Resize(20, 1)
n = False
For Each cell In r
If cell.Formula <> "" Then
n = True
End If
Next cell
MsgBox m.Formula
Loop Until n = False
End Sub
This will start at B1 and loop all the way down Column B until the loop encounters a cell at which, beneath it, are 20 contiguous blank cells. When the loop arrives at that cell that has 20 consecutive blanks cells beneath it, it will just Offset to the first of those blank cells beneath it and stop.
If I understand it correctly...
You'll need to convert hard coded ranges to variables
You are using offset correctly
I know while/wend is outdated, sorry :)
Sub IsNumeric()
dim tc as range
set tc = range("B6") 'this is always column B, but the row keeps changing in the loop
'IF(ISNUMBER(C6),C6,
while tc <> ""
If Application.IsNumber(tc.offset(0,1).Value) Then
tc.offset(0,2).Value = tc.offset(0,1)
'IF(C6<C5,((OFFSET(C6,2,0)-OFFSET(C6,-1,0))*A6/3+OFFSET(C6,-1,0)),
If tc.offset(0,1) < tc.offset(-1,1) Then
tc.offset(0,2).Value = tc.Offset(2, 1) - tc.Offset(-1, 1) * (tc.offset(0,-1) / 3) + tc.Offset(-1, 1)
'IF(C6<>C7,((OFFSET(C6,1,0)-OFFSET(C6,-2,0))*(A6/3)+OFFSET(C6,-2,0)),"")))
If tc.offset(0,1) <> tc.offset(1,1) Then
tc.offset(0,2) = tc.offset(1,1) - tc.offset(-2,1) * (tc.offset(0,-1) / 3) + tc.offset(-2,1)
Else
tc.offset(0,2) = ""
End If
End If
End If
set tc=tc.offset(1,0)
wend
End Sub