EXCEL: highlighting reoccuring data in the same column - excel

I have a column(D) of data in Excel that has been sorted using:
=TEXT(B2,"###").
This is to show a list of data (numberical) that has an additional "REP 1" against it.
Not all data has a "REP 1" in there, so I would like to highlight all fields which contain BOTH the number and the "REP 1".
I could highlight all "REP 1" fields, and see if there is a duplicate before it, but this is just a sample sheet. I have over 8,000+ fields to go through, and would be too time consuming.
Please see the below link for the example:
Required Formatting
I hope this all makes sense.
Thanks,
Tim.

Not sure if its possible to do with conditional formatting but this VBA code should work. Your Data wouldn't have to be sorted in any particular order, and assumes the data you are formatting is in column D. I've tested on a few 100 rows and it works fine, so should be fine with a large data set. Ive tried to explain what the code is doing through the comments in the code.
Sub formatCells()
Dim x As Variant
Dim y As Variant
Dim searchval As String
Dim a As Variant
Dim lastrow As Long
Dim rng As Range
Application.ScreenUpdating = False ' turn off screen updates
lastrow = Cells(Rows.Count, 4).End(xlUp).Row 'find the last blank cell
x = 2 'set rownumber
y = 4 'set columnnumber
While Cells(x, y) <> "" ' create loop
If InStr(Cells(x, y), "REP1") Then 'search for string in cell
Cells(x, y).Interior.Color = RGB(255, 0, 0) 'if string exists fill cell
End If
x = x + 1 ' loop
Wend ' end loop
x = 2 ' reset row number
y = 4 ' reset column number
While Cells(x, y) <> "" ' create loop 2
If Cells(x, y).Interior.Color = RGB(255, 0, 0) And InStr(Cells(x, y), "REP1") Then 'if cells is red and contains Rep1
a = Cells(x, y).Value ' set a to equal the cell that is red and and contains REP1
searchval = Left(a, Len(a) - 5) 'remove space and REP1 and set value ready for search
If searchval <> "" Then 'if theres a search value available run steps below
With Range("D1:D" & lastrow) 'set range to be column A
Set rng = .Find(What:=searchval, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rng Is Nothing Then 'If search value is found
Application.Goto rng, True ' go to cell
ActiveCell.Interior.Color = RGB(255, 0, 0) 'set cell to red
End If
End With
End If
End If
x = x + 1 'loop 2
Wend ' end loop 2
End Sub
EDIT - Looks at column B not D
Sub formatCells()
Dim x As Variant
Dim y As Variant
Dim searchval As String
Dim a As Variant
Dim lastrow As Long
Dim rng As Range
Application.ScreenUpdating = False ' turn off screen updates
lastrow = Cells(Rows.Count, 2).End(xlUp).Row 'find the last blank cell
x = 2 'set rownumber
y = 2 'set columnnumber
While Cells(x, y) <> "" ' create loop
If InStr(Cells(x, y), "REP1") Then 'search for string in cell
Cells(x, y).Interior.Color = RGB(255, 0, 0) 'if string exists fill cell
End If
x = x + 1 ' loop
Wend ' end loop
x = 2 ' reset row number
y = 2 ' reset column number
While Cells(x, y) <> "" ' create loop 2
If Cells(x, y).Interior.Color = RGB(255, 0, 0) And InStr(Cells(x, y), "REP1") Then 'if cells is red and contains Rep1
a = Cells(x, y).Value ' set a to equal the cell that is red and and contains REP1
searchval = Left(a, Len(a) - 5) 'remove space and REP1 and set value ready for search
If searchval <> "" Then 'if theres a search value available run steps below
With Range("B1:B" & lastrow) 'set range to be column A
Set rng = .Find(What:=searchval, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rng Is Nothing Then 'If search value is found
Application.Goto rng, True ' go to cell
ActiveCell.Interior.Color = RGB(255, 0, 0) 'set cell to red
End If
End With
End If
End If
x = x + 1 'loop 2
Wend ' end loop 2
End Sub

Related

Finding key words in Excel with VBA

The file I am working on is picking the selected words from all the comments, colors them and segregates them into the dedicated tabs.
All keywords have been coded into the macro itself. Instead of writing the keywords to the macro, I want to tell the macro the keywords are located in an array in an excel sheet so everybody can use the file according to their needs.
When I made below changes for keywords to an array, I am getting below error on the screenshot that I do not know why.
Satellite:
KeyW = Array("Satellite", "image", "blacks out", "resolution")
Satellite:
KeyW = Array(Worksheets("MAIN").Range("N5:N15"))
The code below was not written by me. I just made some modifications.
Error that I am getting:
runtime error 13, Type mismatch
when I click debug it shows this yellow line
Sub sort()
Dim KeyW()
Dim cnt_Rows As Long, cnt_Columns As Long, curr_Row As Long, i As Long, x As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Sheets(Array("Television", "Satellite", "News", "Sports", "Movies", "Key2", "Key3", "Error", "Commercial", "Key4", "TV", "Key5", "Key6", "Signal", "Key1", "Key7", "Design", "Hardware")).Select
Satellite:
KeyW = Array("Satellite", "image", "blacks out", "resolution")
KeyWLen = UBound(KeyW, 1)
j = 2
For i = 0 To KeyWLen
With Worksheets(1).Range("c4:e7000")
Set c = .Find(KeyW(i), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Sheets("Satellite").Range("b" & j).Value = Worksheets(1).Range("a" & c.Row).Value
Worksheets(1).Range(c.Address).Copy
Sheets("Satellite").Activate
Range("a" & j).Select
Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
, SkipBlanks:=False, Transpose:=False
Range("a" & j).Select
WordPos = 1
StartPos = 1
SearchStr = KeyW(i)
While WordPos <> 0
WordPos = InStr(StartPos + 1, Range("a" & j).Value, SearchStr, 1)
If WordPos > 0 _
Then
With ActiveCell.Characters(Start:=WordPos, Length:=Len(SearchStr)).Font
.FontStyle = "Bold"
.Color = -16727809
End With
StartPos = WordPos
End If
Wend
Worksheets(1).Activate
j = j + 1
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Next i
I'd start by splitting out some of the logic into standalone methods, and calling them from your main code: this makes it easier to see what's going on and allows some re-use of your code later on.
For example:
Sub sort()
Dim wb As Workbook
Dim txt As String, allCells As Collection, c As Range, w As Range, rngDest As Range
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set wb = ThisWorkbook
'(removed sheet selection code - not needed here)
Set rngDest = wb.Worksheets("Satellite").Range("A2") 'start listing matches here
For Each w In wb.Worksheets("MAIN").Range("N5:N15").Cells 'loop over possible search terms
txt = Trim(w.Value)
If Len(txt) > 0 Then
Set allCells = FindAll(wb.Worksheets(1).Range("c4:e7000"), txt) 'get all matches
For Each c In allCells
c.Copy rngDest 'copy matched cell
BoldWord rngDest, txt 'bold matched text
rngDest.Offset(0, 1) = _
c.EntireRow.Columns("A").Value 'copy colA from matched cell
Set rngDest = rngDest.Offset(1) 'next result row
Next c
End If
Next w
End Sub
'return a Collection of all cells in `rng` which contain `txt`
Public Function FindAll(rng As Range, txt As String) As Collection
Dim rv As New Collection, f As Range
Dim addr As String
Set f = rng.Find(what:=txt, after:=rng.Cells(rng.Cells.Count), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not f Is Nothing Then addr = f.Address()
Do Until f Is Nothing
rv.Add f
Set f = rng.FindNext(after:=f)
If f.Address() = addr Then Exit Do
Loop
Set FindAll = rv
End Function
'Bold all instances of `wrd` in cell `c`
Sub BoldWord(c As Range, txt As String)
Dim pos As Long, start As Long
start = 1
Do
pos = InStr(start, c.Value, txt, vbTextCompare)
If pos = 0 Then Exit Do
With c.Characters(pos, Len(txt))
.Font.Bold = True
.Font.Color = vbRed
End With
start = pos + Len(txt)
Loop
End Sub

Highlighting Values In Column to Column Comparison using VBA

I am attempting to compare two columns in two separate sheets, each column contains data that is a string. My issue is that there is data in one column that is identical to the other in separate rows; therefore I have to check the entire column for the data before moving to the next. I am very inexperienced with VBA and am trying to make one portion of my job easier rather than comparing the columns by hand. I have piece wised the following code from research and trial and error. I am able to get the entire Column searched in my first Sheet, but only one value is being highlighted on the second sheet and then it is returning a value of "True" in the first column. I am unsure where I have gone wrong, any help is greatly appreciated!
Sub Better_Work_This_Time()
Dim FindString As String
Dim Rng As Range
ActiveCell = Sheets("Last Week").Range("A2").Activate
FindString = ActiveCell
Dim County As Integer
Count = Cells.CurrentRegion.rows.Count
For i = 2 To County
If Trim(FindString) <> "" Then
With Sheets("Current Week").Range("A:A")
Set Rng = .Find(What:=FindString, After:=.Cells(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
If Not Rng Is Nothing Then
ActiveCell.Font.Color = vbBlue
End If
End With
End If
If IsEmpty(FindString) Then
FindString = False
End If
ActiveCell.Offset(1, 0).Select
i = i + 1
Next
End Sub
Without using ActiveCell and using Match instead of Find.
Option Explicit
Sub Does_Work_This_Time()
Dim wb As Workbook, wsLast As Worksheet, wsCurrent As Worksheet
Dim FindString As String, ar, v
Dim LastRow As Long, i As Long, n As Long
Set wb = ThisWorkbook
' put current week values into array
Set wsCurrent = wb.Sheets("Current Week")
With wsCurrent
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
ar = .Range("A2:A" & LastRow).Value2
End With
' scan last week matching current week
Set wsLast = wb.Sheets("Last Week")
With wsLast
.Columns(1).Interior.Color = xlNone
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 2 To LastRow
FindString = Trim(.Cells(i, "A"))
If Len(FindString) > 0 Then
v = Application.Match(FindString, ar, 0)
If IsError(v) Then
'no match
ElseIf ar(v, 1) = FindString Then ' case match
.Cells(i, "A").Interior.Color = RGB(128, 255, 128) ' light green
n = n + 1
End If
End If
Next
End With
MsgBox n & " rows matched"
End Sub

Change color of text in a cell of excel

I would like to change the color of a text in a cell in MS Excel like the conditioned formatting. I have different text in one cell, e.g. "WUG-FGT" or "INZL-DRE". I would like to format the cells (all cells in my workshhet), that a defined text like "WUG-FGT" appears red and the other text "INZL-DRE" green, but the text is in the same cell. With "sandard" conditioned formatting I only get the backgroud coloured.
A similar questions is this: How can I change color of text in a cell of MS Excel?
But the difference is that I (actually) don't work with programming. That means that I need a more simple or easy solution to implement this in my excel file.
Is this possible? A solution with VBA would also be possible, I know how to implement them.
here example how you can achieve required results:
Sub test()
Dim cl As Range
Dim sVar1$, sVar2$, pos%
sVar1 = "WUG-FGT"
sVar2 = "INZL-DRE"
For Each cl In Selection
If cl.Value2 Like "*" & sVar1 & "*" Then
pos = InStr(1, cl.Value2, sVar1, vbTextCompare)
cl.Characters(pos, Len(sVar1)).Font.Color = vbRed
End If
If cl.Value2 Like "*" & sVar2 & "*" Then
pos = InStr(1, cl.Value2, sVar2, vbTextCompare)
cl.Characters(pos, Len(sVar2)).Font.Color = vbGreen
End If
Next cl
End Sub
test
UPDATE
Is it possible to count how often the word has been detected. Either to write to total amount to a defined cell or what also would be great, to add the number of counts in brackets behind the word with an control variable? So in your example: A2: "WUG-FGT(1)", A4: "WUG-FGT(2)", A5: "WUG-FGT(3)"
Yes, but you should update the cell before colorizing, otherwise whole cell font will be colorized by the first char's color (e.g. cell contains both keywords and first is red, and second is green, after update whole cell font will be red). See updated code and test bellow:
Sub test_upd()
Dim cl As Range, sVar1$, sVar2$, pos%, cnt1%, cnt2%
Dim bVar1 As Boolean, bVar2 As Boolean
sVar1 = "WUG-FGT": cnt1 = 0
sVar2 = "INZL-DRE": cnt2 = 0
For Each cl In Selection
'string value should be updated before colorize
If cl.Value2 Like "*" & sVar1 & "*" Then
bVar1 = True
cnt1 = cnt1 + 1
cl.Value2 = Replace(cl.Value, sVar1, sVar1 & "(" & cnt1 & ")")
End If
If cl.Value2 Like "*" & sVar2 & "*" Then
bVar2 = True
cnt2 = cnt2 + 1
cl.Value2 = Replace(cl.Value, sVar2, sVar2 & "(" & cnt2 & ")")
End If
pos = InStr(1, cl.Value2, sVar1, vbTextCompare)
If bVar1 Then cl.Characters(pos, Len(sVar1)).Font.Color = vbRed
pos = InStr(1, cl.Value2, sVar2, vbTextCompare)
If bVar2 Then cl.Characters(pos, Len(sVar2)).Font.Color = vbGreen
bVar1 = False: bVar2 = False
Next cl
End Sub
test
Change Format of Parts of Values in Cells
Links
Workbook Download
Image
The Code
'*******************************************************************************
Sub CFF(Range As Range, SearchString As String, _
Optional ColorIndex As Long = -4105, _
Optional OccurrenceFirst0All1 As Long = 1, _
Optional Case1In0Sensitive As Long = 1)
' ColorIndex
' 3 for Red
' 10 for Green
' OccurrenceFirst0All1
' 0 - Only First Occurrence of SearchString in cell of Range.
' 1 (Default) - All occurrences of SearchString in cell of Range.
' Case1In0Sensitive
' 0 - Case-sensitive i.e. aaa <> AaA <> AAA
' 1 (Default) - Case-INsensitive i.e. aaa = AaA = AAA
Const cBold As Boolean = False ' Enable Bold (True) for ColorIndex <> -4105
Dim i As Long ' Row Counter
Dim j As Long ' Column Counter
Dim rngCell As Range ' Current Cell Range
Dim lngStart As Long ' Current Start Position
Dim lngChars As Long ' Number of characters (Length) of SearchString
' Assign Length of SearchString to variable.
lngChars = Len(SearchString)
' In Range.
With Range
' Loop through rows of Range.
For i = .Row To .Row + .Rows.Count - 1
' Loop through columns of Range.
For j = .Column To .Column + .Columns.Count - 1
' Assign current cell range to variable.
Set rngCell = .Cells(i, j)
' Calculate the position of the first occurrence
' of SearchString in value of current cell range.
lngStart = InStr(1, rngCell, SearchString, Case1In0Sensitive)
If lngStart > 0 Then ' SearchString IS found.
If OccurrenceFirst0All1 = 0 Then ' FIRST occurrence only.
GoSub ChangeFontFormat
Else ' ALL occurrences.
Do
GoSub ChangeFontFormat
lngStart = lngStart + lngChars
lngStart = InStr(lngStart, rngCell, SearchString, _
Case1In0Sensitive)
Loop Until lngStart = 0
End If
'Else ' SearchString NOT found.
End If
Next
Next
End With
Exit Sub
ChangeFontFormat:
' Font Formatting Options
With rngCell.Characters(lngStart, lngChars).Font
' Change font color.
.ColorIndex = ColorIndex
' Enable Bold for ColorIndex <> -4105
If cBold Then
If .ColorIndex = -4105 Then ' -4105 = xlAutomatic
.Bold = False
Else
.Bold = True
End If
End If
End With
Return
End Sub
'*******************************************************************************
Real Used Range (RUR)
'*******************************************************************************
' Purpose: Returns the Real Used Range of a worksheet.
' Returns: Range Object or "Nothing".
'*******************************************************************************
Function RUR(Optional NotActiveSheet As Worksheet) As Range
Dim objWs As Worksheet
If Not NotActiveSheet Is Nothing Then
Set objWs = NotActiveSheet
Else
Set objWs = ActiveSheet
End If
If objWs Is Nothing Then Exit Function
Dim HLP As Range ' Cells Range
Dim FUR As Long ' First Used Row Number
Dim FUC As Long ' First Used Column Number
Dim LUR As Long ' Last Used Row Number
Dim LUC As Long ' Last Used Column Number
With objWs.Cells
Set HLP = .Cells(.Cells.Count)
Set RUR = .Find("*", HLP, xlFormulas, xlWhole, xlByRows)
If Not RUR Is Nothing Then
FUR = RUR.Row
FUC = .Find("*", HLP, , , xlByColumns).Column
LUR = .Find("*", , , , xlByRows, xlPrevious).Row
LUC = .Find("*", , , , xlByColumns, xlPrevious).Column
Set RUR = .Cells(FUR, FUC) _
.Resize(LUR - FUR + 1, LUC - FUC + 1)
End If
End With
End Function
'*******************************************************************************
Usage
The following code if used with the Change1Reset0 argument set to 1, will change the format in each occurrence of the desired strings in a case-INsensitive search.
'*******************************************************************************
Sub ChangeStringFormat(Optional Change1Reset0 As Long = 0)
Const cSheet As Variant = "Sheet1"
Const cStringList As String = "WUG-FGT,INZL-DRE"
Const cColorIndexList As String = "3,10" ' 3-Red, 10-Green
' Note: More strings can be added to cStringList but then there have to be
' added more ColorIndex values to cColorIndexList i.e. the number of
' elements in cStringList has to be equal to the number of elements
' in cColorIndexList.
Dim rng As Range ' Range
Dim vntS As Variant ' String Array
Dim vntC As Variant ' Color IndexArray
Dim i As Long ' Array Elements Counter
Set rng = RUR(ThisWorkbook.Worksheets(cSheet))
If Not rng Is Nothing Then
vntS = Split(cStringList, ",")
If Change1Reset0 = 1 Then
vntC = Split(cColorIndexList, ",")
' Loop through elements of String (ColorIndex) Array
For i = 0 To UBound(vntS)
' Change Font Format.
CFF rng, CStr(Trim(vntS(i))), CLng(Trim(vntC(i)))
Next
Else
For i = 0 To UBound(vntS)
' Reset Font Format.
CFF rng, CStr(Trim(vntS(i)))
Next
End If
End If
End Sub
'*******************************************************************************
The previous codes should all be in a standard module e.g. Module1.
CommandButtons
The following code should be in the sheet window where the commandbuttons are created, e.g. Sheet1.
Option Explicit
Private Sub cmdChange_Click()
ChangeStringFormat 1
End Sub
Private Sub cmdReset_Click()
ChangeStringFormat ' or ChangeStringFormat 0
End Sub
Try:
Option Explicit
Sub test()
Dim rng As Range, cell As Range
Dim StartPosWUG As Long, StartPosINL As Long
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
For Each cell In rng
StartPosWUG = InStr(1, cell, "WUG-FGT")
StartPosINL = InStr(1, cell, "INZL-DRE")
If StartPosWUG > 0 Then
With cell.Characters(Start:=StartPosWUG, Length:=Len("WUG-FGT")).Font
.Color = vbRed
End With
End If
If StartPosINL > 0 Then
With cell.Characters(Start:=StartPosINL, Length:=Len("INZL-DRE")).Font
.Color = vbGreen
End With
End If
Next
End With
End Sub

Identify range in an Excel outline group

I have an Excel sheet that has data grouped using the outline method.
I'm having issues defining a range from the beginning of the group to the end of the group.
I have this data populating a listbox in a userform.
If a user selected any item in this group to delete I need to remove the whole group.
I think I am over thinking it but is there a good way to define this range?
Here is a sample of what I am starting with below
`Sub delrows()
Dim StartRow As Integer
Dim EndRow As Integer
'if outline level should never drop below 2.
'If it is 2 then this will always be the beginning of the range.
If ActiveCell.Rows.OutlineLevel = 2 Then
y = ActiveCell.Row
Else
y = ActiveCell.Row + 3
'y= needs to look up until it see a 2 then go back down 1 row
End If
If ActiveCell.Rows.OutlineLevel <> 2 Then
x = ActiveCell.Row + 1
'x = needs to look down until it finds next row 2 then back up 1 row
Else
x = ActiveCell.Row
End If
StartRow = y
EndRow = x
Rows(StartRow & ":" & EndRow).Select '.Delete
End Sub`
Worked on it a little bit. Have the outline level stored as a value on the sheet in column AA.
Sub delrows()
Dim StartRow As Integer
Dim EndRow As Integer
Dim Rng As Range
Dim C As Range
Dim B As Range
'if outline level shoudl never drop below 2.
'If it is 2 then this will always be the begining of the range.
If ActiveCell.Rows.outlinelevel = 2 Then
'If ActiveCell = 2 Then
y = ActiveCell.Row
Else
Set Rng = Range("AA:AA")
Set B = Rng.Find(What:="2", After:=ActiveCell,LookIn:=xlFormulas,LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
y = B.Offset(0, 0).Row
End If
If ActiveCell.Rows.outlinelevel <> 2 Then
Set Rng = Range("AA:AA")
Set C = Rng.Find(What:="2", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
x = C.Offset(-1, 0).Row
Else
If ActiveCell.Rows + 1 = 3 Then
Set Rng = Range("AA:AA")
Set C = Rng.Find(What:="2", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
x = C.Offset(-1, 0).Row
Else
x = ActiveCell.Row
End If
End If
StartRow = y
EndRow = x
Rows(StartRow & ":" & EndRow).Delete
End Sub
Try this:
Option Explicit
Public Sub RemoveGroup()
Dim grpStart As Range, grpEnd As Range, lvl As Long
Set grpStart = Sheet1.Range("A7").EntireRow 'test cell - A7
Set grpEnd = grpStart
lvl = grpStart.OutlineLevel
While lvl = grpStart.OutlineLevel 'find start of current group (up)
Set grpStart = grpStart.Offset(-1)
Wend
Set grpStart = grpStart.Offset(1) 'exclude 1st row in next group
While lvl = grpEnd.OutlineLevel 'find end of current group (down)
Set grpEnd = grpEnd.Offset(1)
Wend
Set grpEnd = grpEnd.Offset(-1) 'exclude 1st row in next group
With Sheet1.Rows(grpStart.Row & ":" & grpEnd.Row)
.ClearOutline
.Delete
End With
End Sub
Before and After:

Check if cells are empty

I am doing a macro that checks whether cells are empty or full. But is there any fast way to check if only one cell out of three, in a row, is not empty?
my code:
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
ThisWorkbook.Sheets(1).Range("A1").Select
Do Until ActiveCell.row = LastRow + 1
If IsEmpty(ActiveCell) = False Then
If IsEmpty(Cells(ActiveCell.row, 1)) = False And IsEmpty(Cells(ActiveCell.row, 1)) = False And IsEmpty(Cells(ActiveCell.row, 3))=False And IsEmpty(Cells(ActiveCell.row, 4))=False Then
MsgBox "None empty empty"
ElseIf IsEmpty(Cells(ActiveCell.row, 1)) = True And IsEmpty(Cells(ActiveCell.row, 2)) = True And IsEmpty(Cells(ActiveCell.row, 3)) = True And IsEmpty(Cells(ActiveCell.row, 4)) = True Then
MsgBox "All empty"
End If
End If
ActiveCell.Offset(1, 0).Select
Loop
But is there a way to check if only one two or three out of 4 cells are not empty?
I am looking for. In my code i would like it to check the following:
If IsEmpty(Cells(ActiveCell.row, 1)) = False And IsEmpty(Cells(ActiveCell.row, 1)) = False And IsEmpty(Cells(ActiveCell.row, 3))=True And IsEmpty(Cells(ActiveCell.row, 4))=True Then MsgBox "2 empty"
So if 2 are empty and two are not it shpuld always check it. I dont want to write a lot of if statements that is why i am asking if there is any faster way-
For a specific set of cells, A1 through D1
One way:
Sub EmptyCounter()
Dim rng As Range
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
Set rng = Range("A1:D1")
MsgBox "There are " & 4 - wf.CountA(rng) & " empties"
End Sub
Here we explicitly ignore the case of Null strings.
As per your sample code your objective is to identify when:
All cells 4 first cells in row are empty or
All cells 4 first cells in row are not empty
Rows with a mix of empty and not empty cells are ignored
Suggest the use of objects, also to marked (either with color or with a value in an adjacent cell) the cells found.
Below you have two sets of codes one showing a message for each row with full values or totally empty (as you have now) and also a sample with the suggestion of coloring the resulting cells.
Rem Code showing messages
Sub Wsh_MarkCellsEmptyAndNotEmpty_Msg()
Dim RngTrg As Range
Dim lRowLast As Long
Dim vCellsValue As Variant
Dim lRow As Long
Dim bNoneEmpty As Byte
Dim b As Byte
Rem No changes to your method for finding last row
lRowLast = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Rem Set Target Range
Set RngTrg = ThisWorkbook.Sheets(1).Range(Cells(1), Cells(lRowLast, 4))
For lRow = 1 To lRowLast
With RngTrg.Rows(lRow)
Rem To Select cells [NOT RECOMMENDED PRACTICE]
Rem Instead suggest to marked cells found
.Select
Rem Initiate Variables
bNoneEmpty = 0
vCellsValue = Empty
Rem Look into cells values
For b = 1 To 4
If .Cells(b).Value <> Empty Then bNoneEmpty = 1 + bNoneEmpty
vCellsValue = vCellsValue & .Cells(b).Value2
Next
Rem Show Message with Results
If vCellsValue = Empty Then
MsgBox "All Cells are empty"
ElseIf bNoneEmpty = 4 Then
MsgBox "None Cell is empty"
End If
End With: Next
End Sub
Rem Code marking cells with color (user friendly)
Sub Wsh_MarkCellsEmptyAndNotEmpty_Color()
Dim RngTrg As Range
Dim lRowLast As Long
Dim vCellsValue As Variant
Dim lRow As Long
Dim bNoneEmpty As Byte
Dim b As Byte
Rem No changes to your method for finding last row
lRowLast = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Rem Set Target Range
Set RngTrg = ThisWorkbook.Sheets(1).Range(Cells(1), Cells(lRowLast, 4))
Rem To Clear Cells Colors if marking with colors cells found
RngTrg.Interior.Pattern = xlNone
For lRow = 1 To lRowLast
With RngTrg.Rows(lRow)
Rem Initiate Variables
bNoneEmpty = 0
vCellsValue = Empty
Rem Look into cells values
For b = 1 To 4
If .Cells(b).Value <> Empty Then bNoneEmpty = 1 + bNoneEmpty
vCellsValue = vCellsValue & .Cells(b).Value2
Next
Rem Mark Resulting cells
If vCellsValue = Empty Then
Rem Colors Empty Cells in Red
.Interior.Color = RGB(255, 199, 206)
ElseIf bNoneEmpty = 4 Then
Rem Colors No Empty Cells in Green
.Interior.Color = RGB(198, 239, 206)
End If
End With: Next
End Sub

Resources