Excel: Hiding cells that are not colored - vba

I have a script that changes the cell color and a script to hide the cells that are not colored. The hide script works, but it hides ALL the cells, even the colored ones. I noticed that when I use the script that changes the cell color, it does not detect the changes in the excel interface(in the 'Fill Color' settings in 'Home' tab, under the 'font size' selection). I also noticed that when try to change the color of the cells (using the excel interface) that are colored from using the script, it does not change (the color seems to be fixed to whatever is set from the script).
Therefore, it seems like the interface does not detect the changes that are being made using the coloring script.
Also, I noticed the script below takes a while to check/hide all the cells. If there is a way to speed up the process, that would be great!
Any help will be greatly appreciated!
Thank you!
The script to hide uncolored cells:
Public Sub HideUncoloredRows()
Dim startColumn As Integer
Dim startRow As Integer
Dim totalRows As Integer
Dim totalColumns As Integer
Dim currentColumn As Integer
Dim currentRow As Integer
Dim shouldHideRow As Integer
startColumn = 1 'column A
startRow = 1 'row 1
totalRows = Sheet1.Cells(Rows.Count, startColumn).End(xlUp).Row
For currentRow = totalRows To startRow Step -1
shouldHideRow = True
totalColumns = Sheet2.Cells(currentRow, Columns.Count).End(xlToLeft).Column
'for each column in the current row, check the cell color
For currentColumn = startColumn To totalColumns
'if any colored cell is found, don't hide the row and move on to next row
If Not Sheet1.Cells(currentRow, currentColumn).Interior.ColorIndex = -4142 Then
shouldHideRow = False
Exit For
End If
Next
If shouldHideRow Then
'drop into here if all cells in a row were white
Sheet2.Cells(currentRow, currentColumn).EntireRow.Hidden = True
End If
Next
End Sub
The script that changes the color certain cells:
Range("A8").Select
Application.CutCopyMode = False
Range("A8").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=COUNTIF(Name_Preps,A8)=1"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Font
.Bold = True
.Italic = False
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3 'Changes the cell to green
.TintAndShade = 0.4
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub

Try to change your condition to follow
For currentColumn = startColumn To totalColumns
'if any colored cell is found, don't hide the row and move on to next row
If Sheet1.Cells(currentRow, currentColumn).Interior.ThemeColor = xlThemeColorAccent3 Then
shouldHideRow = False
Exit For
End If
Next

conditional formatting is not detected by Interior.ColorIndex and the likes
if you want to go on that way you can see here or here for relevant code
but I'd abandon conditional formatting as well as Select/Selection/Activate/ActiveXXX pattern and go simply this way:
Option Explicit
Sub HandleRowsColorAndVisibility()
Dim iRow As Long
With Range("A8", Cells(Rows.count, 1).End(xlUp)) '<--| reference cells from A8 down to column A last not empty cell
ResetRange .Cells '<--| first, bring range formatting and visibility back to a "default" state
For iRow = .Rows.count To 1 Step -1 '<--| then start looping through range
If WorksheetFunction.CountIf(Range("Name_Preps"), .Cells(iRow, 1)) = 1 Then '<-- if current cell matches your criteria ...
FormatRange .Cells(iRow, 1), True, False, 0, xlColorIndexAutomatic, xlThemeColorAccent3, 0.4 '<--| then format it
Else '<--| otherwise...
.Rows(iRow).Hidden = True '<--| hide it!
End If
Next
End With
End Sub
Sub ResetRange(rng As Range)
rng.EntireRow.Hidden = False
FormatRange rng, False, False, 0, xlColorIndexAutomatic, -4142, 0
End Sub
Sub FormatRange(rng As Range, okBold As Boolean, okItalic As Boolean, myFontTintAndShade As Single, myPatternColorIndex As XlColorIndex, myInteriorThemeColor As Variant, myInteriorTintAndShade As Single)
With rng
With .Font
.Bold = okBold
.Italic = okItalic
.TintAndShade = myFontTintAndShade
End With
With .Interior
.PatternColorIndex = myPatternColorIndex
.ThemeColor = myInteriorThemeColor
.TintAndShade = myInteriorTintAndShade
End With
End With
End Sub

Related

How to find a specific cell and replace by a text

On an active range selection, how to find only the cells that contains "0" and "#N/A" - and replace it by text "NA" and change the font color to "red".
Here is the macro I am using to "convert formulas to absolute values " and "to find empty cells to put text "NA".
sub XConvertToValues()
Dim MyRange As Range
Dim MyCell As Range
Set MyRange = Selection
For Each MyCell In MyRange
If MyCell.HasFormula Then
MyCell.Formula = MyCell.Value
End If
If IsEmpty(MyCell.Value) = True Then
MyCell.Value = "NA"
End If
Next MyCell
End Sub
edited after OP's clarification about data format
use Replace() and AutoFilter() method of Range object
Sub XConvertToValues()
With Selection
.Value = .Value '<--| convert all formulas to their values
.Replace What:="#N/A", replacement:="NA", LookAt:=xlWhole
.Replace What:="0", replacement:="NA", LookAt:=xlWhole
If WorksheetFunction.CountIf(.Cells, "NA") > 0 Then
.AutoFilter field:=1, Criteria1:="NA"
.Resize(IIf(.Cells(1) = "NA", .Rows.count, .Rows.count - 1)).Offset(IIf(.Cells(1) = "NA", 0, 1)).SpecialCells(xlCellTypeVisible).Font.ColorIndex = 3
.Parent.AutoFilterMode = False
End If
End With
End Sub
i'm beginner too , this what can i make and maybe it will help you , you can just put number of cells you want to change or rewrite the code with FOR EACH
Dim i As Integer
On Error Resume Next
For i = 1 To 20
cells.Find(What:="0", MatchCase:=False_, SearchFormat:=False).Activate
ActiveCell.FormulaR1C1 = "NA"
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
cells.Find(What:="#N/A", MatchCase:=False_, SearchFormat:=False).Activate
ActiveCell.FormulaR1C1 = "NA"
With Selection.Font
.Color = -16776961
.TintAndShade = 0
End With
Next i
edit
Now as you have provided more info, this can be done like:
Try this
Sub ConvertToValues()
Dim R As Long
k = Sheet1.Range("A1048576").End(xlUp).Row '-> total rows in column A
For R = 1 To k
If IsEmpty(Sheet1.Cells(R, 2)) = True Or Sheet1.Cells(R, 2) = "#NA" Or Sheet1.Cells(R, 2) = "0" Then
Sheet1.Cells(R, 2).Value = "NA"
Sheet1.Cells(R, 2).Font.Color = RGB(255, 0, 0)
End If
Next R
End Sub

Highlight all rows equal to value in cell foobar

I am trying to code this procedure to highlight all rows of which have a value of "N" in their respective row within Column N
I am not too familiar with coding VBA formatting and I cannot get this procedure to function
Sub highlight_new_pos()
Dim rng As Range, lCount As Long, LastRow As Long
Dim cell As Object
With ActiveSheet 'set this worksheet properly!
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In .Range("N2:N" & LastRow)
If cell = "N" Then
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Next cell
End With
End Sub
Option Explicit
Sub highlight_new_pos()
Dim cel As Object
With ActiveSheet
For Each cel In .Range("N2:N" & .Cells(.Rows.Count, 14).End(xlUp).Row)
If UCase(cel.Value2) = "N" Then cel.Interior.Color = 65535
Next
End With
End Sub
This will be faster if you have a lot of rows:
Sub highlight_new_pos1()
Application.ScreenUpdating = False
With ActiveSheet
With .Range("N1:N" & .Cells(.Rows.Count, 14).End(xlUp).Row)
.AutoFilter Field:=1, Criteria1:="N"
.Offset(1, 0).Resize(.Rows.Count - 14, .Columns.Count).Interior.Color = 65535
.AutoFilter
End With
End With
Application.ScreenUpdating = True
End Sub
In your code, you are looping through the cells, but you're still changing the color of the initial selection (not of the cell in the loop). Adjust as follows:
Sub highlight_new_pos()
Dim rng As Range, lCount As Long, LastRow As Long
Dim cell As Object
With ActiveSheet 'set this worksheet properly!
LastRow = .Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In .Range("N2:N" & LastRow)
If cell = "N" Then
With cell.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.Color = 65535
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End if
Next cell
End With
End Sub
If you want the entire row, change cell.Interior to cell.entirerow.Interior

VBA to loop through column if the header is not empty

I want to start looping through each column if the column header is not blank. I don't know how to locate the header of each column as it is letter, not number.
I googled many codes but they are not doing exactly I want.
Below is the code. Any help would be appreciated.
Sub ColorGradient()
'Find the last roll number
Dim Lastrow As Integer
Lastrow = Range("A:A").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim cs As ColorScale
Dim rng As Range
'Loop through each column
For Each rng In Range("B4:AA" & Lastrow).Columns
'Set color gradient
Set cs = rng.FormatConditions.AddColorScale(ColorScaleType:=3)
' Set the color of the lowest value
With cs.ColorScaleCriteria(1)
.Type = xlConditionValueLowestValue
With .FormatColor
.Color = RGB(248, 105, 107)
.TintAndShade = 0
End With
End With
' In the middle
With cs.ColorScaleCriteria(2)
.Type = xlConditionValuePercentile
.Value = 50
With .FormatColor
.Color = RGB(255, 244, 189)
.TintAndShade = 0
End With
End With
' At the highest value
With cs.ColorScaleCriteria(3)
.Type = xlConditionValueHighestValue
With .FormatColor
.Color = RGB(0, 204, 255)
.TintAndShade = 0
End With
End With
Next rng
End Sub
I'm not sure I understand completely, but test that the "header" row value is not blank first, then set your column range and do stuff to it.
Option Explicit
Sub test()
Dim rHdrs As Range
Dim r As Range
Dim rCol As Range
Dim Lastrow As Integer
With ThisWorkbook.Sheets(1)
Lastrow = .Columns(1).Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set rHdrs = .Range("B3:AA3")
For Each r In rHdrs
If r.Value <> "" Then
Set rCol = .Range(.Cells(4, r.Column), .Cells(Lastrow, r.Column))
'loop through cells in rCol
'do stuff with the non-empty header column ranges here
End If
Next r
End With
End Sub
I assumed you were doing this on Thisworkbook.sheets(1).

VBA Delete Empty Cells with Multiple Column Selection

I am having a small amount of trouble with finding a possible solution to a potential problem of mine. I am writing a macro for my supervisor using VBA so that she can just click a button assigned to this macro and follow the directions and get the data she needs. The issue I'm running into is when the macro pastes the data, it has trouble deleting empty cells if the user selects multiple columns.
Sub DataPull()
' Written by Agony
' Data Pull macro
Dim rng1 As Range
Dim rng2 As Range
Dim chc1
Dim chc2
Dim wb1 As Workbook
Dim wb2 As Workbook
'Choose file to get data
chc1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file to pull data from")
If chc1 = False Then Exit Sub
'Choose file to paste data
chc2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
, "Please select file to paste data to")
If chc2 = False Then Exit Sub
'Open first file and copy range
Set wb1 = Workbooks.Open(chc1)
Set rng1 = Application.InputBox("Select cells to transfer", "Selection", "Use your mouse/pointer to select the cells", Type:=8)
rng1.Copy
wb1.Close SaveChanges:=False
'Open second file and paste with specs
Set wb2 = Workbooks.Open(chc2)
Set rng2 = Range("A1")
rng2.PasteSpecial
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Name = "Cambria"
.Size = 12
.TintAndShade = 0
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
Selection.Borders(xlEdgeLeft).LineStyle = xlNone
Selection.Borders(xlEdgeTop).LineStyle = xlNone
Selection.Borders(xlEdgeBottom).LineStyle = xlNone
Selection.Borders(xlEdgeRight).LineStyle = xlNone
Selection.Borders(xlInsideVertical).LineStyle = xlNone
Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
'Loop to delete empty cells
Dim i As Long
Dim rows As Long
Dim rng3 As Range
Set rng3 = ActiveSheet.Range("A1:Z50")
rows = rng3.rows.Count
For i = rows To 1 Step (-1)
If WorksheetFunction.CountA(rng3.rows(i)) = 0 Then rng3.rows(i).Delete
Next
wb2.Activate
MsgBox ("Macro Complete")
End Sub
As above shows, the range is currently tentative. I would like the function to delete cells that are empty if the user selects a range with multiple columns. I've tried using Len for the cells, but that doesn't seem to work either. Any help is greatly appreciated. Thanks!
I don't think you can use the .Copy and .Paste when the source workbook is closed.
I think that whatever you're copying gets lost when the workbook is closed.
So a possible solution to your problem would be to close the wb1 at the end of your macro and not immediately after the copy command.
So move wb1.Close SaveChanges:=False to after this block
...
'Open second file and paste with specs
Set wb2 = Workbooks.Open(chc2)
Set rng2 = Range("A1")
rng2.PasteSpecial
With Selection.Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
With Selection.Font
.Name = "Cambria"
.Size = 12
.TintAndShade = 0
End With
wb1.Close SaveChanges:=False ' moved it here
...
Deletetion
Try this sub see if this is what you want. What this does it finds the last column used in spreadsheet and last row in each column. Iterates back from the last row in each column and deletes all empty cells shifting the filled cells up.
Sub DeleteAllAtOnce()
Application.ScreenUpdating = False
Dim lastColumn As Long
Dim lastRow As Long
lastColumn = ActiveSheet.UsedRange.Columns.Count
Dim i As Long, j As Long
Dim cell As Range
For i = lastColumn To 1 Step -1
lastRow = Cells(rows.Count, i).End(xlUp).Row
For j = lastRow To 1 Step -1
Set cell = Cells(j, i)
If IsEmpty(cell) Then cell.Delete shift:=xlUp
Next j
Next i
Application.ScreenUpdating = True
End Sub

Highlighting duplicates column by column

I'm trying to go go through columns and highlight duplicates within the columns.
I used record macro to get an idea of what I need but I'm not sure how to apply this across many columns. Highlighting all columns won't work because many of the names repeat. I need to find out if a name repeats multiple times within a list.
This is the code I have so far:
Sub findDuplicates()
Application.Goto Reference:="R3C18:R89C18"
Application.Goto Reference:="R3C18:R88C18"
Selection.FormatConditions.AddUniqueValues
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
.Color = -16751204
.TintAndShade = 0
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.Color = 10284031
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
Range("R21").Select
End Sub
This is code I have that goes through each column within my range from B3:OA3 and sorts by color and alphabet. My thinking is that because this code goes column by column and sorts, I could simply add to it to highlight duplicates within the column it was already sorting. But I'm not sure how'd I'd do that.
Sub sortColorThenAlpha()
'sort by color then by alphabet
Dim rngFirstRow As Range
Dim rng As Range, rngSort As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
Set rngFirstRow = ws.Range("B3:OA3")
For Each rng In rngFirstRow.Cells
With ws.Sort
Set rngSort = rng.Resize(86, 1) 'to row 88
.SortFields.Clear
.SortFields.Add(rng, xlSortOnCellColor, xlAscending, , xlSortNormal). _
SortOnValue.Color = RGB(198, 239, 206)
.SortFields.Add Key:=rng, SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.SetRange rngSort
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Next rng
Application.ScreenUpdating = True
End Sub
This is what I'm looking at. That yellow conditinal formatting is what I'm trying to apply to each column between row 3 and 88.
VBA does not seem necessary as Conditional Formatting with the following rules seems to work:
=A1=VLOOKUP(A1,A2:A$99,1,FALSE) Applies to: =$A$1:$J$99
=A2=VLOOKUP(A2,A$1:A1,1,FALSE) Applies to: =$A$2:$J$99
with references adjusted to suit.
If I understand your question correctly, you want to be able to highlight duplicates in a single column, and you want to be able to automatically apply this formatting to all columns in a given sheet. So if Cleopatra appears once in several columns, she won't be highlighted, but if she appears more than once in a single column, she will.
The following code does just that. I'm finding the last column by looking for a value in row 3.
Sub HighlightDupesOneColumnAtATime()
Dim ws As Worksheet
Dim myColumn As Long
Dim i As Integer
Dim columnCount As Long
Dim lastRow As Long
Dim dupeColor As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
columnCount = ws.Cells(3, ws.Columns.Count).End(xlToLeft).Column
dupeColor = 9944516
For i = 1 To columnCount
lastRow = ws.Cells(ws.Rows.Count, i).End(xlUp).Row
Call HighlightDupesInRange(dupeColor, Cells(1, i).Resize(lastRow, 1))
' it is easy to change the color of the
' highlighted duplicates if you want
dupeColor = dupeColor + 15
Next i
End Sub
Sub HighlightDupesInRange(cellColor As Long, rng As Range)
With rng
.FormatConditions.Delete
.FormatConditions.AddUniqueValues
.FormatConditions(1).DupeUnique = xlDuplicate
.FormatConditions(1).Interior.Color = cellColor
.FormatConditions(1).StopIfTrue = False
End With
End Sub