I have an excel spreadsheet of a BOM that I'm trying to conditionally format. The data is laid out such that column A is the item number. Since the BOM has alternates, there are repeated numbers. I want to go through the spreadsheet and for each item number, find the item with "Active" in column F and highlight them green and hide the alternates on the other rows. If there is no "active" item, I want to highlight the items as yellow and keep them displayed. I have the current vba script which does the highlighting. If you look at the example data I basically want a single line for each item number which shows the active part, but if there is no active part, to show the historical or discontinued parts in yellow
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim icolor As Integer
Dim lastrow As Long
Dim i As Integer
Dim cell As Range
Dim sheetname As String
sheetname = Application.ActiveSheet.Name
With Worksheets(sheetname)
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Application.ScreenUpdating = False
For Each cell In Range("F1:F" & lastrow)
Select Case cell.Value
Case Is = "Active"
cell.EntireRow.Interior.ColorIndex = 10
Case Is = "Status"
cell.EntireRow.Interior.ColorIndex = 15
Case Is = ""
cell.EntireRow.Interior.ColorIndex = 2
cell.EntireRow.Hidden = True
Case Else
cell.EntireRow.Interior.ColorIndex = 6
End Select
Next cell
Application.ScreenUpdating = True
End Sub
Here's a screenshot of some sample data:
You need to set the row height to zero to hide it
cell.EntireRow.RowHeight = 0
But don't forget to reset it in the other two cases
cell.EntireRow.AutoFit
Please check to see if the cell value is NULL as well as ""
Related
I'm new to vba and trying to automate some data analysis. Within the raw data, I have formatted cells to highlight those between two user input criteria. Now I need to find the rows where all the cells in that row are highlighted. I tried the following. Pardon formatting I'm on mobile.
Sub Hold()
Dim cell as range
Dim rowdata as range
Dim s as long
Dim rc as long
Dim n as Boolean
rc = range("C10", range("C10").end(xldown)).rows.count
For s = 0 to rc
Set rowdata = range("C10", range("C10").end(xltoright)).offset(s , 0)
For each cell in RowData
If cell.interior.color <> 11389944 Then
n = false
Exit for
End if
Next cell
If n = false then
Rowdata.font.color = rgbred
Else
Rowdata.font.color = rgbgreen
End if
Next s
End Sub
I manually searched to find a row where all the cells are highlighted within the row. As I debugged, I expected the font to change to green. It did not. I noticed the second if statement had n = false even though I expected it to be true since in that row cell.interior.color = 11389944. What am I missing here?
I have a table (X by Y) with random cells filled in red (it can range from all cells filled in in the column, to some filled in cells, to no filled in cell in the column). I would like to hide the columns that have no cells filled in. The code below looks for the cells filled in red and hides the entire column regardless if there are any cell not filled in. I would like to hide the columns with no cells filled in.
Dim cell As Range
For Each cell In Selection
If cell.Interior.Color = vbRed Then 'finds the filled in cells
Columns(cell.Column).EntireColumn.Hidden = True 'hides the column with filled in cells
End If
Next
Thank you in advance.
This will hide columns with no red cells in the column:
Dim cell As Range
Dim c as long
For c = 1 to selection.columns.count
Dim redFound as Boolean
redFound = False
Dim r as Long
For r = 1 to Selection.Rows.Count
If Selection.Cells(r,c).Interior.Color = vbRed Then
redFound = True
Exit For
End If
Next
Selection.Columns(c).EntireColumn.Hidden = redFound
Next
I think maybe you need identify a variable to record the status which need be hidden or not. Here I named 'Flag' to record whether column need be hidden or not.
Sub Hidden_Column()
Dim Flag As Boolean
Dim iRow As Integer
Dim iClm As Integer
Dim ColorNum
With Sheet1
For iClm = 1 To .Cells(1, 256).End(xlToLeft).Column
Flag = True
For iRow = 1 To .Cells(65536, 1).End(xlUp).Row
ColorNum = .Cells(iRow, iClm).Interior.ColorIndex
If ColorNum <> -4142 Then 'no color
Flag = False
Exit For
End If
Next iRow
If Flag = True Then
Columns(Cells(iRow, iClm).Column).EntireColumn.Hidden = True
End If
Next iClm
End With
End Sub
I am new to VBA and was wondering how I combine 2 worksheet_change scripts, or if there is something else I should use.
I have a dropdown list which when selected give dependancy to another dropdown list.
For the first dropdown I have code which filters the columns so the other columns are hidden. There are several columns which have the same text in row 3 making multiple columns associated with the first dropdown. The code below works fine for B2.
Users may stop at the first dropdown, but if they then select the second dropdown I need the spreadsheet to filter the columns further so only one column is displayed. The heading titles are in row 4.
At the moment I have:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
Dim the_selection As String
Dim the_group As String
the_selection = Sheet1.Range("B2")
Dim Rep as Integer
For Rep = 5 to 100
the_column = GetColumnLetter_ByInteger(Rep)
the_group = Sheet1.Range(the_column & "3")
If the_selection = the_group Then
Sheet1.Range(the_column & ":" & the_column).EntireColumn.Hidden = False
Else
Sheet1.Range(the_column & ":" & the_column).EntireColumn.Hidden = True
End If
Next Rep
End If
End Sub
If I try and create a Worksheet_SelectionChange for the C2 dropdown it sort of works but I have to click out of the cell and then in again for it to filter properly. This is not ideal. Is there a way of incorporating the codes together in the Worksheet_change.
Additionally, is it possible for the second selection to also filter the rows so only those with values appear and the blank ones are hidden? The second filter would always filter to one column and never more than one. What code would I add to reset the row filter when a user selected another dropdown?
Any help is appreciated.
Lando :)
Your original code could be rewritten as
Private Sub Worksheet_Change(ByVal Target As Range)
Dim the_selection As String
Dim the_group As String
Dim Rep As Long
If Target.Address = "$B$2" Then
the_selection = Sheet1.Range("B2") 'If this code is in Sheet1 you can just use "the_selection=Target".
For Rep = 5 To 100
the_group = Sheet1.Cells(3, Rep)
Sheet1.Columns(Rep).Hidden = (the_selection <> the_group)
Next Rep
End If
End Sub
Sheet1.Columns(Rep).Hidden requires TRUE or FALSE to hide/show the
column.
(the_selection <> the_group) will return TRUE if
the_selection is different from the_group and FALSE if not.
Your combined code could be:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim the_selection As String
Dim the_group As String
Dim Rep As Long
If Not Intersect(Target, Range("B2:C2")) Is Nothing Then
the_selection = Target
'Unhide all columns if B2 is changed.
If Target.Address = "$B$2" Then
Sheet1.Columns.Hidden = False
End If
For Rep = 5 To 100
the_group = Sheet1.Cells(Target.Column + 1, Rep)
Select Case Target.Address
Case "$B$2"
Sheet1.Columns(Rep).Hidden = (the_selection <> the_group)
Case "$C$2"
If Not Sheet1.Columns(Rep).Hidden Then
Sheet1.Columns(Rep).Hidden = (the_selection <> the_group)
End If
End Select
Next Rep
End If
End Sub
The code will take the value from B2 or C2 (the_selection=Target).
B2 looks at row 3, C2 looks at row 4 - column B is also column 2, column C is also column 3 so the code just adds one to get the correct row number (the_group = Sheet1.Cells(Target.Column + 1, Rep)).
If the value being changed is C2 then you don't want to unhide any columns already hidden by B2 so the code checks if the column is not already hidden before attempting to hide it (If Not Sheet1.Columns(Rep).Hidden Then)
I have some people, whose working time are shown by the conditional formatting in the cells on their own columns - e.g. B7:B36, C7:C36, D7:D36 and so. I try to count the conditional formatting cells to the column E. The end result in the cell is #Value (Arvo), but when you press F9, then the numbers can be displayed.
When I run the code step by step, I noticed that after the line "Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats program jump to function "Function CountRed(MyRange As Range" and stay in the Loop for some time.
Is this because that there is a function "CountRed(B6)+CountGreen(C6)+CountBlue(D6)" for example in the cell E6?
In addition, I would like the column numbers in column E are concentrated in the central.
Error if exit time is empty:
Result with error in col E:
Results should look like this:
The original code can be also found here - Thanks Floris!
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
If Not Intersect(target, Range("B4:Q4")) Is Nothing Then
'Sub makeTimeGraph()
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim Applicaton
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 0.000001 ' a very small number - to take care of rounding errors in lookup
Dim entryName
Dim Jim
Dim Mark
Dim Lisa
Dim nameCols As Range
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B4 in this case:
entryTimeRow = 4
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A6:
Set timeRange = Range("A6", [A6].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
Set nameCols = Range("B3:Q3") ' columns where the names are in the third row
' clear previous formatting
Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).ClearFormats
Application.ScreenUpdating = False
' loop over each of the columns:
For Each c In timeCols.Cells
Application.StatusBar = entryName
If IsEmpty(c) Then GoTo nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
entryName = c.Offset(-1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
'select format range
formatRange.Select
' select name for coloring
Select Case entryName
Case "Jim"
Call formatTheRange1(formatRange) ' Red Colorinex 3
Case "Mark"
Call formatTheRange2(formatRange) ' Green Colorindex 4
Case "Lisa"
Call formatTheRange3(formatRange) ' Blue Colorindex 5
End Select
nextColumn:
Next c
End If
Range("A1").Activate
Application.ScreenUpdating = True
End Sub
Private Sub formatTheRange1(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color red coloroindex 3
With r.Interior
.Pattern = xlSolid
.ColorIndex = 3
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Private Sub formatTheRange2(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color Green Colorindex 4
With r.Interior
.Pattern = xlSolid
.ColorIndex = 4
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Private Sub formatTheRange3(ByRef r As Excel.Range)
r.HorizontalAlignment = xlCenter
r.Merge
' Apply color Blue Colorindex 5
With r.Interior
.Pattern = xlSolid
.ColorIndex = 5
'.TintAndShade = 0.8
Selection.UnMerge
End With
End Sub
Function CountRed(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 3 Then
i = i + 1
End If
Next cell
CountRed = i
End Function
Function CountGreen(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 4 Then
i = iCount + 1
End If
Next cell
CountGreen = i
End Function
Function CountBlue(MyRange As Range)
Dim i As Integer
Application.Volatile
i = 0
For Each cell In MyRange
If cell.Interior.ColorIndex = 5 Then
i = i + 1
End If
Next cell
CountBlue = i
End Function
The #VALUE!(ARVO) error could be overcome by adding ws.Calculate to the end of your Private Sub worksheet_change(ByVal target As Range) procedure.
That said, your desired outcomes:
Graphic representation of time being worked by employees
How many people are working during different time intervals
Can be accomplished using conditional formatting in columns B:D and COUNTIFS functions in column E.
To set up the conditional format in column B:
Select from B6 down to the cell adjacent to the last time in column A
Click Conditional Formatting and click on the "Use a formula..." option
Enter =AND(A6>=B$4,$A6<B$5) in the formula box
Click the Format.. button and select Fill colour
Click OK
Click Apply or OK to see the result or close the dialogue
You can copy the conditional formats to columns C and D then edit their fill colours as desired.
In cell E6 inter the formula:
=COUNTIFS(A6,">="&B$4,A6,"<"&B$5)
+COUNTIFS(A6,">="&C$4,A6,"<"&C$5)
+COUNTIFS(A6,">="&D$4,A6,"<"&D$5)
Copy from B6 down to E last time row into F6; J6 etc.
By not using VBA at all you will improve worksheet performance. It's usually better to use Excel functionality and built-in functions where possible and reserve VBA to do repetitive tasks and create UDFs to calculate thing that can't be done using built-in functions.
Hyvää päivää! It's me again… Good to see you are continuing to improve your code. I have made a few tweaks to make it work a bit better. In particular:
Modified the test of the Target - so it will update both when you change the start time, and when you change the end time. You were only doing things when the start time was changed.
Just one formatting function instead of 3, with a second parameter (color). This keeps the code a little tidier. You could even have a dictionary of key/value pairs - but that doesn't work on a Mac which is where I'm writing this so I won't show you.
Hidden inside the colored cell is the number 1, with the same color as the background (hence "invisible") - this is added by the formatting function
Now your "sum" column can just contain a SUM(B6:D6) style formula that you copy down the column. This is considerably faster than three custom functions that check for the color in the cells to their left… (removed those functions from the code)
Have to clear the entire column's values (not just formatting) to remove any 1s left over from a previous run; this is done in the per-column loop (rather than all at once) to preserve the SUM() formulas in the "per day" columns.
Nothing is ever selected by the code - so there's nothing to unselect at the end; this means that the selection doesn't jump to the A1 cell every time you make an edit.
Removed the Dim Jim etc statements since you did not use those variables.
Now that the code is modifying the sheet (changing the values in cells by adding the invisible ones) there is a risk of things really slowing down (every change causes the event to fire again) - so I am turning off the events when you enter the function, and turn them on again when you leave (using Application.EnableEvents = False or True respectively); to be safe, errors are also trapped (with On Error GoTo whoops) - these send your code straight to the "enable events and exit function" part of the code.
Presumably you have figured out that this code needs to live in the worksheet code (rather than a regular module) in order to receive the events properly.
Here is the new code:
Option Explicit
Private Sub worksheet_change(ByVal target As Range)
On Error GoTo whoops
If Not Intersect(target, Range("B4:Q5")) Is Nothing Then
Dim startRow As Long
Dim endRow As Long
Dim entryTimeRow As Long
Dim entryTimeFirstCol As Long
Dim Applicaton
Dim ws As Excel.Worksheet
Dim timeRange As Range
Dim c
Dim timeCols As Range
Dim entryTime
Dim exitTime
Dim formatRange As Excel.Range
Dim eps
eps = 1e-06 ' a very small number - to take care of rounding errors in lookup
Dim entryName
Dim nameCols As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
' change these lines to match the layout of the spreadsheet
' first cell of time entries is B4 in this case:
entryTimeRow = 4
entryTimeFirstCol = 2
' time slots are in column A, starting in cell A6:
Set timeRange = Range("A6", [A6].End(xlDown))
' columns in which times were entered:
Set ws = ActiveSheet
Set timeCols = Range("B4:Q4") ' select all the columns you want here, but only one row
Set nameCols = Range("B3:Q3") ' columns where the names are in the third row
' clear previous values and formatting
Range("B6", ws.Cells.SpecialCells(xlCellTypeLastCell)).clearFormats
' loop over each of the columns:
For Each c In timeCols.Cells
'Application.StatusBar = entryName
If IsEmpty(c) Then GoTo nextColumn
entryTime = c.Value
exitTime = c.Offset(1, 0).Value
entryName = c.Offset(-1, 0).Value
startRow = Application.WorksheetFunction.Match(entryTime + eps, timeRange) + timeRange.Cells(1.1).Row - 1
endRow = Application.WorksheetFunction.Match(exitTime - eps, timeRange) + timeRange.Cells(1.1).Row - 1
' get rid of any values currently in this row:
timeRange.Offset(0, c.Column - 1).Clear
Set formatRange = Range(ws.Cells(startRow, c.Column), ws.Cells(endRow, c.Column))
' select name for coloring
Select Case entryName
Case "Jim"
Call formatTheRange(formatRange, 3) ' Red Colorindex 3
Case "Mark"
Call formatTheRange(formatRange, 4) ' Green Colorindex 4
Case "Lisa"
Call formatTheRange(formatRange, 5) ' Blue Colorindex 5
End Select
nextColumn:
Next c
End If
whoops:
If Err.Number > 0 Then
MsgBox "error: " & Err.Description
Err.Clear
End If
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Private Sub formatTheRange(ByRef r As Excel.Range, c)
Dim cc
' Apply color c
With r.Interior
.Pattern = xlSolid
.ColorIndex = c
End With
r.Font.ColorIndex = c
' put an invisible 1 in each cell:
For Each cc In r.Cells
cc.Value = 1
Next
End Sub
Here's how things look (just one set of columns showing - but this should work fine in your multi-column version):
I am not a fan of writing macro, unless you exhausted the capabilities of Excel. Instead of attacking the problem through the ColorIndex, go back to the source of your data. Use this formula on E6
{=SUM(($B$4:$D$4<=A6)*($B$5:$D$5>A6))}
Remember to use Ctrl+Shift+Enter to enable the array function, instead of just Enter. Paste down and it will perform the behavior you are aiming for.
Here's what I need to do:
1) Loop through every cell in a worksheet
2) Make formatting changes (bold, etc) to fields relative to each field based on the value
What I mean is that if a field has a value of "foo", I want to make the field that is (-1, -3) from it bold, etc. I tried to do this with the following script with no luck.
Thanks
Johnny
Pseudo Code to Explain:
For Each Cell in WorkSheet
If Value of Cell is 'Subtotal'
Make the cell 2 cells to the left and 1 cell up from here bold and underlined
End If
End ForEach
The Failed Macro (I don't really know VB at all):
Sub Macro2()
'
'
'
Dim rnArea As Range
Dim rnCell As Range
Set rnArea = Range("J1:J2000")
For Each rnCell In rnArea
With rnCell
If Not IsError(rnCell.Value) Then
Select Case .Value
Case "000 Total"
ActiveCell.Offset(-1, -3).Select
ActiveCell.Font.Underline = XlUnderlineStyle.xlUnderlineStyleSingleAccounting
End Select
End If
End With
Next
End Sub
Option Explicit
Private Sub macro2()
Dim rnArea As Range
Dim rnCell As Range
' you might need to change the range to the cells/column you want to format e. g. "G1:G2000" '
Set rnArea = Range("J1:J2000")
For Each rnCell In rnArea
With rnCell
If isBold(.Offset(1, 3).Value) Then
.Font.Bold = True
End If
If isUnderlined(.Offset(1, 3).Value) Then
'maybe you want this: .Font.Underline = xlUnderlineStyleSingle '
.Font.Underline = xlUnderlineStyleSingleAccounting
End If
End With
Next
End Sub
Private Function isBold(cellValue As Variant) As Boolean
Dim myList() As Variant
Dim listCount As Integer
Dim i As Integer
myList = Array("Totals", "FooTotal", "SpamTotal")
listCount = 3
isBold = False
For i = 0 To listCount - 1
If cellValue = myList(i) Then
isBold = True
Exit Function
End If
Next i
End Function
Private Function isUnderlined(cellValue As Variant) As Boolean
Dim myList() As Variant
Dim listCount As Integer
Dim i As Integer
myList = Array("FooTotal", "SpamTotal")
listCount = 2
isUnderlined = False
For i = 0 To listCount - 1
If cellValue = myList(i) Then
isUnderlined = True
Exit Function
End If
Next i
End Function
I added two functions but it should have also worked with an extensive if / else if / else.
Based on the comments on the solution above, i think this might be helpful
Sub FormatSpecialCells()
Dim SearchRange As Range
Dim CriteriaRange As Range
Set SearchRange = Range("A2:A24")
Set CriteriaRange = Range("C2:C5")
Dim Cell As Range
For Each Cell In SearchRange
TryMatchValue Cell, CriteriaRange
Next
End Sub
Private Sub TryMatchValue(CellToTest As Range, CellsToSearch As Range)
Dim Cell As Range
For Each Cell In CellsToSearch
If Cell.Value = CellToTest.Value Then
Cell.Copy
CellToTest.PasteSpecial xlPasteFormats, xlPasteSpecialOperationNone, False, False
End If
Next
End Sub
This does not fully accomplish your goal. What it does is it searches a specified list of cells, and it matches them against a seperate list of cells. If it matches the values, it takes the FORMAT of the second list of cells and applies it to the cell it matched in the first list of cells. You can modify this by changing the TryMatchValue function so that instead of matching the CellToTest, it pastes the format onto another cell which is 2 across and one up.
This has the advantage that, if you want to add more values and different formats, you only need to go to your excel sheet and add more values. Also you only need to change the format on that value.
An example would be...
Have the cells you are searching in A1:D1000
Have these values in cells E2:E6...
Subtotal (which is bold and underlined)
Total (which is bold, underlined and italic)
Net (which is bold underlined and Red)
etc...
then when it hits Subtotal, it will change the cell to be bold and underlined.
When it hits Total it will change the cell to be bold underlined and italic
etc etc...
hope this helps
Would the conditional formatting functionality in excel give you what you need without having to write a macro?