How to find a cell value within the visible range - excel

I have a long list of entries to go through very quickly, where one of the columns, Column F, changes fairly often. Since I'm going through each entry individually, I want to highlight the entire row red where the value in Column F changes so that it's easy to see. Here's what I've written so far:
Dim visRng As Range, rngTop As Long, rngBot As Long
rngTop = ActiveWindow.visiblerange.Row
rngBot = ActiveWindow.visiblerange.Row + ActiveWindow.visiblerange.Rows.Count - 2
visRng = Worksheets("Work").Range("F" & rngTop, "F" & rngBot)
For Each Cell In visRng
If Cell.Value = Cell.Offset(-1).Value _
And Cell.Interior.ColorIndex = 0 Then
Cell.EntireRow.Interior.ColorIndex = 3
End If
Next
I keep getting an error on the row where I define "visRng":
Runtime Error '91':
Object variable or With block variable not set
I am fairly new to VBA, and self-taught, so I can't guarantee I'll understand all the jargon. Any help is greatly appreciated!

See comments for explanation.
Sub FindAndColor()
Dim visRng As Range
Dim rngCell As Range
'/ Set to range object. Yiu can't simply asign to it.
'/ This will get rid of Error 91
'/ Just Use VisibleCells of the usedRange
Set visRng = Worksheets("Work").UsedRange.SpecialCells(XlCellType.xlCellTypeVisible)
'/ Loop through the range
For Each rngCell In visRng.Cells
If rngCell.Row <> 1 Then
If rngCell.Value = rngCell.Offset(-1).Value _
And rngCell.Interior.ColorIndex = -4142 Then '/ -4142 is the default interior colorindex
rngCell.EntireRow.Interior.ColorIndex = 3
End If
End If
Next
End Sub

Related

Is there a better way to get the value of the first cell that is centered across selection for the current cell?

Given that I am told we should be using Centered Across Selection instead of Merged Cells, I need to get the underlying value that is displayed across the cells when formatted as Centered Across Selection.
When using Merged Cells, it was easy:
CellValue = rng.MergeArea.Cells(1, 1).Value
Is there an easy way to get the same for Centered Across Selection, other than searching backwards while HorizontalAlignment = xlHAlignCenterAcrossSelection until the Cell Value <> "". My code to do this would be:
Function GetCenteredAcrossSelectionCellValue(rng As Range) As Variant
Dim i As Long
Dim l As Long
Dim ws As Worksheet
Set ws = rng.Worksheet
i = rng.Column
r = rng.Row
If rng.HorizontalAlignment = xlHAlignCenterAcrossSelection Then
Do Until (ws.Cells(r, i).Value <> "" And rng.HorizontalAlignment = xlHAlignCenterAcrossSelection)
i = i - 1
Loop
End If
GetCenteredAcrossSelectionCellValue = ws.Cells(r, i).Value
End Function
However, I don't this this is foolproof, because it could be possible that someone applied Center Across Selection to a single cell (say A1 for example) with a value, and then applied Center Across Selection to 3 empty cells (B1:D1). When asked for the "value" for D1, the above code would return the value in A1.
Excel must know because it formats correctly, so is there an easy way to tell in VBA, similar to the way we can tell for Merged Cells?
Following on from the comment above...
Apply "center across selection" to A1:J1 then run tester with values in different cells in that range and compare the outputs.
Sub tester()
Dim c As Range, rng As Range
For Each c In Range("A1:J1")
Set rng = CenteredRange(c)
If Not rng Is Nothing Then
Debug.Print c.Address, rng.Address
Else
Debug.Print c.Address, "not centered"
End If
Next c
End Sub
'return the current "center across" range given a starting point
Function CenteredRange(c As Range) As Range
Dim cStart As Range, cEnd As Range, cNext As Range
Set c = c.Cells(1) 'make sure we're dealing with a single cell
If Not c.HorizontalAlignment = xlCenterAcrossSelection Then Exit Function
Set cStart = c.Parent.Range(c.Address)
Set cEnd = c.Parent.Range(c.Address)
'look for the beginning
Do While cStart.Column > 1 And cStart.HorizontalAlignment = xlCenterAcrossSelection
If Len(cStart.Value) > 0 Then Exit Do 'stop if find a value
Set cStart = cStart.Offset(0, -1)
Loop
'look for the end
Do While cEnd.Column < Columns.Count - 1 And cEnd.HorizontalAlignment = xlCenterAcrossSelection
Set cNext = cEnd.Offset(0, 1) 'checking the next cell...
If Len(cNext.Value) > 0 Or cNext.HorizontalAlignment <> xlCenterAcrossSelection Then Exit Do
Set cEnd = cEnd.Offset(0, 1)
Loop
Set CenteredRange = c.Parent.Range(cStart, cEnd)
End Function

Using for loops to identify rows

I tried here, here, and here.
I'm trying to highlight a row based on the string contents of a cell in the first column.
For example, if a cell in the first column contains the string "Total", then highlight the row a darker color.
Sub tryrow()
Dim Years
Dim rownum As String
Years = Array("2007", "2008", "2009") ' short example
For i = 0 To UBound(Years)
Set rownum = Range("A:A").Find(Years(i) & " Total", LookIn:=xlValues).Address
Range(rownum, Range(rownum).End(xlToRight)).Interior.ColorIndex = 1
Next i
End Sub
I get this error message:
Compile error: Object required
The editor highlights rownum = , as if this object hadn't been initialized with Dim rownum As String.
You've got a couple issues here, indicated below alongside the fix:
Sub tryrow()
Dim Years() As String 'Best practice is to dim all variables with types. This makes catching errors early much easier
Dim rownum As Range 'Find function returns a range, not a string
Years = Array("2007", "2008", "2009") ' short example
For i = 0 To UBound(Years)
Set rownum = Range("A:A").Find(Years(i) & " Total", LookIn:=xlValues) 'Return the actual range, not just the address of the range (which is a string)
If Not rownum Is Nothing Then 'Make sure an actual value was found
rownum.EntireRow.Interior.ColorIndex = 15 'Instead of trying to build row range, just use the built-in EntireRow function. Also, ColorIndex for gray is 15 (1 is black, which makes it unreadable)
End If
Next i
End Sub
You can avoid loop by using autofilter which will work much faster. The code assumes that table starts from A1 cell:
Sub HighlightRows()
Dim rng As Range, rngData As Range, rngVisible As Range
'//All table
Set rng = Range("A1").CurrentRegion
'//Table without header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=1, Criteria1:="*Total*"
'// Need error handling 'cause if there are no values, error will occur
On Error Resume Next
Set rngVisible = rngData.SpecialCells(xlCellTypeVisible)
If Err = 0 Then
rngVisible.EntireRow.Interior.ColorIndex = 1
End If
On Error GoTo 0
End Sub

String comparison over two columns does not return If statement result

I've been successful in getting this string comparison to work with one column. I've expanded the range to two columns and it appears when viewing the locals window that the comparison is taking place. For reasons I've not been able to decipher though the if statement to change the color of the cell if the string comparison is positive does not occur.
Not getting any errors, but also not getting any response.
I've stepped through and watched the local window and everything I've observed there tells me the that the comparison is being made so I'm somewhat baffled as to what could be missing.
Sub ColourDuplicateNameTwoCol() 'Work in progress
Dim baseName As Range
Dim allName As Range
Dim cell As Range
With ThisWorkbook.Worksheets("sheet1")
Set baseName = Range("c1")
Set allName = Range("a1:b7")
For Each cell In allName.cells
If StrComp(baseName.Value, cell.Value, vbTextCompare) = 1 Then
cell.Interior.Color = vbYellow
End If
Next cell
End With
End Sub
Here is the one column working version I mention
Sub ColourDuplicateName() 'Works
Dim baseName As Range
With ThisWorkbook.Worksheets("sheet1")
Set baseName = .Range("b1")
For I = 1 To 7
If StrComp(baseName.Value, cells(I, 1).Value, vbTextCompare) = 1 Then
cells(I, 1).Interior.ColorIndex = 3
End If
Next I
End With
End Sub
Your interpretation of the return value from StrComp is incorrect. Check VBA HELP.
Option Explicit
Sub ColourDuplicateNameTwoCol() 'Work in progress
Dim baseName As Range
Dim allName As Range
Dim cell As Range
With ThisWorkbook.Worksheets("sheet1")
Set baseName = .Range("c1")
Set allName = .Range("a1:b7")
For Each cell In allName.Cells
If StrComp(baseName.Value, cell.Value, vbTextCompare) = 0 Then
cell.Interior.Color = vbYellow
End If
Next cell
End With
End Sub
The above code, which merely shows the StrComp problem you have run into, is not very dynamic. You would have to add code to remove the color, and then add it back, should baseName change. You could, of course, do this with an event Macro.
However, a more dynamic method would be to just set up Conditional Formatting. You would only have to do this once, and it could accomplish the same.
To do this in VBA code, for example:
Option Explicit
Sub ColourDuplicateNameTwoCol() 'Work in progress
Dim baseName As Range
Dim allName As Range
Dim cell As Range
With ThisWorkbook.Worksheets("sheet1")
Set baseName = .Range("c1")
Set allName = .Range("a1:b7")
End With
With baseName.FormatConditions
.Delete
.Add Type:=xlCellValue, _
Operator:=xlEqual, _
Formula1:=baseName
.Item(1).Interior.Color = vbYellow
End With
End Sub
This code will need to be modified if you have other FormatConditions for allNames which you want to retain.

Copy & Paste values if cell value = "N/A"

I want to copy and paste values to a range of cells but only if their value = "N/A". I want to leave the formulas as they are in all the cells that do not = "N/A".
In context, I have hundreds of VLOOKUPs. Example:
=IFERROR(VLOOKUP("L0"&MID(G$4,1,1)&"A0"&MID(G$4,1,1)&MID(G$4,3,2)&"-0"&$B6,Sheet1!$C:$D,2,FALSE),"N/A")
Is this possible with VBA?
First of all, you should use real error values rather than string that only look like errors. Secondly, VLOOKUP returns the N/A error directly if the lookup value is not found, so the IFERROR wrapper can be dispenced with. So the formula
=VLOOKUP("L0"&MID(G$4,1,1)&"A0"&MID(G$4,1,1)&MID(G$4,3,2)&"-0"&$B6,Sheet1!$C:$D,2,FALSE)
is sufficient as is.
To replace N/A results with error values, you can use this
Sub Demo()
Dim ws As Worksheet
Dim rngSrc As Range
Dim datV As Variant, datF As Variant
Dim i As Long
' Get range to process by any means you choose
' For example
Set ws = ActiveSheet
With ws
Set rngSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With
' Copy data to variant arrays for efficiency
datV = rngSrc.Value
datF = rngSrc.Formula
' replace erroring formulas
For i = 1 To UBound(datV, 1)
If IsError(datV(i, 1)) Then
If datV(i, 1) = CVErr(xlErrNA) Then
datF(i, 1) = CVErr(xlErrNA)
End If
End If
Next
' return data from variant arrays to sheet
rngSrc.Formula = datF
End Sub
If you really want to use strings rather than true error values, adapt the If lines to suit
Rather than loop through all cells in a range, you can use SpecialCells to shorten working with the =NA()cells
This also open up a non-VBA method (if the only error cells are NA, ie no Div#/0)
The first two methods below (manual and code) deal with the situation where you only gave NA cells
the third uses SpecialCells to focus on only the cells that need to be tested, before then running a check for NA before making updates
option1
Manual selection of formula cells that evaluate to errors
Select the range of interest
Press [F5].
Click Special
Select Formulas
check only Errors
option2
VBA updating formula cells that evaluate to errors
code
Sub Shorter()
Dim rng1 As Range
On Error Resume Next
' All error formulas in column A
Set rng1 = Columns("A").SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'update with new value (could be value or formulae)
rng1.Value = "new value"
End Sub
option 3
Test for =NA()
Sub TestSpecificRegion()
Dim rng1 As Range
Dim rng2 As Range
Dim X
Dim lngRow As Long
On Error Resume Next
' All error formulas in column A
Set rng1 = Columns("A").SpecialCells(xlCellTypeFormulas, 16)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'update with new value (could be value or formulae)
For Each rng2 In rng1.Areas
If rng2.Cells.Count > 1 Then
X = rng2.Value2
For lngRow = 1 To UBound(X, 1)
If X(lngRow, 1) = CVErr(xlErrNA) Then X(lngRow, 1) = "new value"
Next
rng2.Value = X
Else
If rng2.Value2 = CVErr(xlErrNA) Then rng2.Value = "new value"
End If
Next
End Sub

Type Mismatch on Range For Loop

I am trying to rebuild a worksheet we use daily and in the process make it faster. I've been working with ranges now and trying to incorporate those but ran into a problem when trying to use UsedRange to get the last row for the range than finding it.
My code:
Sub RebuildAllFormat()
Dim SheetRNG As Range, RowDelete As Range, SOSheet As Worksheet
Set SOSheet = ThisWorkbook.Worksheets(Sheet1.Name)
Set SheetRNG = SOSheet.UsedRange.Columns(1)
For Each cell In SheetRNG
If cell.Value = "" Then
Cells(cell.Row, "P").Cut Cells(cell.Row - 1, "P")
If Not RowDelete Is Nothing Then
Set RowDelete = Union(RowDelete, cell)
Else
Set RowDelete = cell
End If
End If
Next cell
RowDelete.EntireRow.Delete
End Sub
The above code gives me the "Type Mismatch" error on If cell.Value = "" Then and it appears that the For loop no longer runs through each cell even though I get the expected value from Debug.Print SheetRNG.Address which is $A$1:$A$1736.
If I replace Set SheetRNG = SOSheet.UsedRange.Columns(1) with
lastrow = SOSheet.Cells(Rows.Count, "B").End(xlUp).Row
Set SheetRNG = SOSheet.Range(SOSheet.Range("A1"), SOSheet.Cells(lastrow, "A"))
then the loop works as expected and I'm able to check values. Running Debug.Print SheetRNG.Address after using the above also returns $A$1:$A$1736.
Am I missing something in the UsedRange code or is it not possible to use it that way?
As others have said, and you yourself identified, the issue is that For Each cell In SheetRNG returns the whole ranhe to cell.
Use For Each cell In SheetRNG.Cells to get each cell individually.
There are other issues in the code as well. See below comments for reccomendations
Sub RebuildAllFormat()
Dim SheetRNG As Range, RowDelete As Range, SOSheet As Worksheet
Dim cell as Range '<~~ Dim all variables
Set SOSheet = Sheet1 '<~~ Sheet1 is already a Worksheet reference
Set SheetRNG = SOSheet.UsedRange.Columns(1) '<~~ May overstate the required range, but will work OK
For Each cell In SheetRNG.Cells
If cell.Value = "" Then
'~~ Qualify the Sheet reference, otherwise it refers to the active sheet
With SOSheet
.Cells(cell.Row - 1, "P") = .Cells(cell.Row, "P") '<~~ faster than Cut/Paste
If Not RowDelete Is Nothing Then
Set RowDelete = Union(RowDelete, cell)
Else
Set RowDelete = cell
End If
End With
End If
Next cell
'~~ Avoid error if no blanks found
If Not RowDelete Is Nothing Then
RowDelete.EntireRow.Delete
End If
End Sub
The .Columns(1) statement does not that work the way you have used it. For example:
Set SheetRNG = Range("A1:B19").Columns(1)
is not the same like:
Set SheetRNG = Range("A1:A19")
You can .Resize() this .UsedRange.
Set SheetRNG = SOSheet.UsedRange.Resize(SOSheet.UsedRange.Rows.Count, 1)

Resources