I'm trying to color rows of data based on some key terms in column A.
Some rows need to be green and some rows need to be red.
I found this online but when I run it nothing happens on the sheet. I don't really know why or how to fix it. This is the version from my excel sheet, so it has all my info in it.
Public Sub ColorCHange2()
Dim mapping As Object, itm As Variant
Set mapping = CreateObject("Scripting.Dictionary")
mapping(XlRgbColor.rgbLightPink) = Array("exclude from emails","exclude from listings")
mapping(XlRgbColor.rgbLightGreen) = Array("include in billing list","include in emails")
Application.ScreenUpdating = False
Sheet1.AutoFilterMode = False
With Sheet1.UsedRange
.Interior.ColorIndex = xlColorIndexNone
For Each itm In mapping
.AutoFilter Field:=1, Criterial1:=mapping(itm), Operator:=xlFilterValues
.Offset(1).Resize(.Rows.Count - 1, .Columns.Count).Interiror.Color = itm
Next
.AutoFiler
End With
Application.ScreenUpdating = True
End Sub
Fixing your typos and the the fact your code doesn't only color visible cells post-filter...
Public Sub ColorCHange2()
Dim mapping As Object, itm As Variant, rngVis As Range
Set mapping = CreateObject("Scripting.Dictionary")
mapping(XlRgbColor.rgbLightPink) = Array("exclude from emails", "exclude from listings")
mapping(XlRgbColor.rgbLightGreen) = Array("include in billing list", "include in emails")
Application.ScreenUpdating = False
Sheet1.AutoFilterMode = False
With Sheet1.UsedRange
.Interior.ColorIndex = xlColorIndexNone
For Each itm In mapping
.AutoFilter Field:=1, Criteria1:=mapping(itm), Operator:=xlFilterValues
Set rngVis = Nothing
On Error Resume Next
Set rngVis = .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rngVis Is Nothing Then rngVis.Interior.Color = itm
Next
.AutoFilter
End With
Application.ScreenUpdating = True
End Sub
Related
I've seen a macro here that works well for filtering and copying data into a new tab. However, it doesn't work when I try to change the filtered column (in this case is column F, but I want to change to column B). See below:
Function GetWorksheet(shtName As String) As Worksheet
On Error Resume Next
Set GetWorksheet = Worksheets(shtName)
End Function
Sub filter()
Application.ScreenUpdating = False
Dim x As Range
Dim rng As Range
Dim last As Long
Dim sht As String
'specify sheet name in which the data is stored
sht = "Sheet1"
'change filter column in the following code
last = Sheets(sht).Cells(Rows.Count, "F").End(xlUp).Row
Set rng = Sheets(sht).Range("A1:F" & last)
Sheets(sht).Range("F1:F" & last).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True
For Each x In Range([AA2], Cells(Rows.Count, "AA").End(xlUp))
With rng
.AutoFilter
.AutoFilter Field:=6, Criteria1:=x.Value
.SpecialCells(xlCellTypeVisible).Copy
Sheets.Add(After:=Sheets(Sheets.Count)).Name = x.Value
ActiveSheet.Paste
End With
Next x
' Turn off filter
Sheets(sht).AutoFilterMode = False
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
End Sub
I'd say if you want this to be re-usable for different sheets then one more layer of abstraction would be useful, so you can call the same sub but with different source ranges:
Sub Tester()
With ThisWorkbook.Worksheets("Sheet1")
FilterRangeToNewSheets .Range("A1:F" & .Cells(.Rows.Count, "F").End(xlUp).Row), 6
End With
End Sub
'Given a range and a column index in that range, add new sheets, one for each
' set of unique values in the range
Sub FilterRangeToNewSheets(rngToFilter As Range, filterColumnIndex As Long)
Dim vals As Collection, k, wb As Workbook
Set wb = rngToFilter.Worksheet.Parent 'parent workbook
Set vals = Uniques(rngToFilter.Columns(filterColumnIndex).Offset(1, 0)) 'offset to exclude the header
For Each k In vals
With rngToFilter
.AutoFilter
.AutoFilter Field:=filterColumnIndex, Criteria1:=k
.SpecialCells(xlCellTypeVisible).Copy
With wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
.Name = k
.Paste Destination:=.Range("A1")
End With
End With
Next k
rngToFilter.Worksheet.AutoFilterMode = False ' Turn off filter
Application.CutCopyMode = False
End Sub
'extract all unique values from a range into a dictionary
Function Uniques(rng As Range) As Collection
Dim col As New Collection, data, c As Range, v
For Each c In rng.Cells
v = c.Value
If Len(v) > 0 Then
On Error Resume Next 'ignore any duplicate key error
col.Add v, v
On Error GoTo 0 'stop ignoring errors
End If
Next c
Set Uniques = col
End Function
Swapped out your Advanced Filter for a function which will return a Collection containing only unique values.
I'm looking to add a checkbox that displays any "Not Found" items.
When this I would like to edit the Listitem
My code currently is working when I open userform2 and edit the Listbox without checking checkbox1.
However, when I checkbox1 is true, it correctly displays the only "Not Found" but when I go to edit the list item I receive run-time error 1004 method range of object _global fail
on:
Set rCell = Range(.RowSource).Resize(1).Offset(.ListIndex)
my full code: for userform2
Private Sub ListBox2_Click()
TextBox1.Enabled = True
TextBox1.Value = ListBox2.Value
End Sub
Private Sub TextBox1_Change()
Dim rCell As Range
With ListBox2
Set rCell = Range(.RowSource).Resize(1).Offset(.ListIndex)
rCell.Value = TextBox1.Value
End With
End Sub
Private Sub CheckBox1_Click()
OptimizedMode True
If userform2.CheckBox1.Value = True Then
Worksheets("Table").Range("A1").AutoFilter Field:=1, Criteria1:="Not Found", Operator:=xlOr, Criteria2:="="
userform2.ListBox2.RowSource = vbNullString
userform2.ListBox2.ColumnHeads = False
Dim rng As Range
Dim Cel1 As Range
Dim LR As Long
Dim ws As Worksheet
Set ws = Sheets("Table")
With ws
LR = .Cells(.Rows.Count, "A").End(xlUp).Row
Set rng = .Range("A2:A" & LR).SpecialCells(xlCellTypeVisible)
With userform2.ListBox2
.ColumnCount = 1
For Each Cel1 In rng
.AddItem CStr(Cel1.Value)
.List(.ListCount - 1, 1) = Cel1.Offset(0, 1).Value
Next Cel1
End With
End With
End If
If CheckBox1.Value = False Then
With userform2.ListBox2
.RowSource = "Table!A2:A1048576"
End With
End If
OptimizedMode False
End Sub
You use CheckBox1_Click event to control ListBox2.RowSource. If CheckBox1 is TRUE you clear RowSource and then add items to the list.
When RowSource is cleared Range(.RowSource) is the same as Range("") which of course errors.
Under these conditions, you'll need to devise another method to determine which row the ListBox refers to.
I have been using a sheet where i have created a manual drop down through "Data Validation" and was using this below code to filter the Column.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
lastrow = Cells(Rows.Count, "I").End(xlUp).Row
With Me
If Not Intersect(Target, .Range("I13")) Is Nothing Then
If Target.Value <> "" Then
.AutoFilterMode = False
.Range("I15:I" & lastrow).AutoFilter field:=1, Criteria1:=Target.Value
End If
End If
End With
End Sub
But now I'm trying to do an ActiveX program that loads the Unique value in ComboBox1 from given range and Filter column using the Value of the ComboBox1.
Here is the code which gets the unique values.
Problem is that i have tried to merge both codes to make it work for ComboBox1 but couldn't make it.
Dim v, e
With Sheets("Sheet1").Range("I16:I10000")
v = .Value
End With
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In v
If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then Sheets("Sheet1").ComboBox1.List = Application.Transpose(.keys)
End With
I want to merge these both codes in one to work. I have tried but failed.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lastrow As Long
With Sheets("Sheet1").Range("I15:I" & lastrow)
v = .Value
End With
With CreateObject("scripting.dictionary")
.comparemode = 1
For Each e In v
If Not .exists(e) Then .Add e, Nothing
Next
If .Count Then Sheets("Sheet1").ComboBox1.List = Application.Transpose(.keys)
End With
lastrow = Cells(Rows.Count, "I").End(xlUp).Row
With Me
If Not Intersect(Target, .Range("I1")) Is Nothing Then
If Target.Value <> "" Then
.AutoFilterMode = False
.Range("I15:I" & lastrow).AutoFilter field:=1, Criteria1:=Target.Value
End If
End If
End With
You do not need the Worksheet_Change event anymore because you are not trapping the value from the data validation cell but from a ComboBox1. Paste this code (Untested) in the Sheet1 code area. The below code will automatically filter when you select an item from the ComboBox1. If you want you can also use a CommandButton to run this code.
Let me know if you face an issue?
Private Sub ComboBox1_Click()
If ComboBox1.ListIndex = -1 Then Exit Sub
Dim ws As Worksheet
Set ws = Sheet1
With ws
.AutoFilterMode = False
LastRow = .Range("I" & .Rows.Count).End(xlUp).Row
.Range("I15:I" & LastRow).AutoFilter Field:=1, Criteria1:=ComboBox1.Value
End With
End Sub
Also you need to load the ComboBox1. You can either do that using a CommandButton or you can use the Workbook_Open() event.
I'm trying to use a shape instead of a button to toggle hiding rows with blank cells (according to conditions). Is it even possible?
Sub ToggleChevron3_Click()
Dim rng As Range, cell As Range
Set rng = Range("A1:C100")
Application.ScreenUpdating = False
With rng
For Each cell In rng
If cell.Offset(0, 4).Value = "" Then ' Condition 1
If cell.Value = "" Then ' Condition 2
ActiveSheet.Shapes("Chevron 3").cell.EntireRow.Hidden _
= Not ActiveSheet.Shapes("Chevron 3").cell.EntireRow.Hidden
End If
End If
Next
End With
Application.ScreenUpdating = True
End Sub
Yes, it is possible. The code to accomplish what I think you are looking for is below. Both pieces of code below assume you want to just click a button to hide / unhide the rows, depending on the current state.
Sub ToggleChevron3_Click()
Application.ScreenUpdating = False
Dim rng As Range, cell As Range
'Set rng = Range("A1:C100") 'do you really want to loop through every cell in columns A through C
Set rng = Range("A1:A100")
For Each cell In rng
If Len(cell.Offset(, 4).Value) = 0 And Len(cell.Value) = 0 Then
Dim bToggle As Boolean
bToggle = cell.EntireRow.Hidden
cell.EntireRow.Hidden = Not bToggle
End If
Next
Application.ScreenUpdating = True
End Sub
However, there is alternative that is cleaner code and faster execution, as long as filtering is okay for you.
Sub ToggleChevron3_Click()
Application.ScreenUpdating = False
Dim bToggle As Boolean
bToggle = ActiveSheet.AutoFilterMode
If bToggle Then
ActiveSheet.AutoFilterMode = False
Else
Dim rng As Range
Set rng = Range("A1:E100") 'used E because you had an offset of 4 columns
With rng
.AutoFilter 5, "<>"
.AutoFilter 1, "<>"
End With
End If
Application.ScreenUpdating = True
End Sub
I am trying to automatically hide/unhide corresponding rows when cell value in column E equals 0 (zero). There are formulas in these cells, and these formulas returns zero when a cell in another changes. Upon that change i would like the code to perform its hide/unhide magic.
Help much appreciated.
Here is a faster method using AutoFilter. You can call this code directly or use it in Worksheet_Calculate event. I am assuming the Cell E1 has Headers.
IN A BUTTON
Option Explicit
Sub Sample()
Dim rRange As Range, RngToHide As Range
Dim lRow As Long
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
With Sheets("Sheet1")
lRow = .Range("E" & Rows.Count).End(xlUp).Row
Set rRange = .Range("E1:E" & lRow)
With rRange
.AutoFilter Field:=1, Criteria1:="0"
Set RngToHide = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
End With
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
If Not RngToHide Is Nothing Then RngToHide.Hidden = True
End Sub
WORKSHEET CALCULATE EVENT - Not Recommended
I do not recommend calling this code automatically as this will not let you unhide the rows in case you want to change something in the hidden rows. To unhide the rows, you will have to either comment out the entire code in the Worksheet_Calculate event or change the value to a non zero value in the connected cell (provided the connected cell in not in the hidden row).
This will hide the row when the value in Col E changes to 0
Option Explicit
Private Sub Worksheet_Calculate()
Dim rRange As Range, RngToHide As Range
Dim lRow As Long
On Error GoTo Whoa
Application.ScreenUpdating = False
Application.EnableEvents = False
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
With Sheets("Sheet1")
lRow = .Range("E" & Rows.Count).End(xlUp).Row
Set rRange = .Range("E1:E" & lRow)
With rRange
.AutoFilter Field:=1, Criteria1:="0"
Set RngToHide = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
End With
End With
'~~> Remove any filters
ActiveSheet.AutoFilterMode = False
If Not RngToHide Is Nothing Then RngToHide.Hidden = True
LetsContinue:
Application.ScreenUpdating = True
Application.EnableEvents = True
Exit Sub
Whoa:
MsgBox Err.Description
Resume LetsContinue
End Sub
Use this mhetod:
Sub HideRows()
Dim i As Integer
i = 1
Do While Not Cells(i, 5) = ""
If Cells(i, 5).Value = 0 Then
Rows(CStr(i) + ":" + CStr(i)).EntireRow.Hidden = True
ElseIf Cells(i, 5).Value <> 0 And Rows(CStr(i) + ":" + CStr(i)).EntireRow.Hidden = True Then
Rows(CStr(i) + ":" + CStr(i)).EntireRow.Hidden = False
End If
i = i + 1
Loop
End Sub
You can add a button and invoke this method by Button_Click event or add next method to necessary Sheet in Microsoft Excel Objects
Private Sub Worksheet_Change()
Module1.HideRows
End Sub
This method will invoke HideRow method when some cell changed.