Check if cells are empty - excel

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

Related

Reliably get Last Column in Excel with or without Merged Cells

I recently ran into an issue where my get_lcol function returned A1 as the cells in A1:D1 were merged. I adapted my function to account for this, but then I had some other data with cells merged in A1:D1 but another column in G and my function returned D1 so I adjusted it again. The problem is I don't trust it still to work with all data types as its only checking merged cells in row 1.
Take a look at the below data, how can I reliably get the function to return D or 4 regardless of where I move the merged row and/or any other issues I haven't foreseen?
Current Function:
Public Sub Test_LCol()
Debug.Print Get_lCol(ActiveSheet)
End Sub
Public Function Get_lCol(WS As Worksheet) As Integer
Dim sEmpty As Boolean
On Error Resume Next
sEmpty = IsWorksheetEmpty(Worksheets(WS.Name))
If sEmpty = False Then
Get_lCol = WS.Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
If IsMerged(Cells(1, Get_lCol)) = True Then
If Get_lCol < Cells(1, Get_lCol).MergeArea.Columns.Count Then
Get_lCol = Cells(1, Get_lCol).MergeArea.Columns.Count
End If
End If
Else
Get_lCol = 1
End If
End Function
Update:
Try this data w/ function:
This is a twist on the classic "Find Last Cell" problem
To state the aim:
find the column number of the right most cell containing data
consider merged cell areas that extend beyond other cells containing data. Return the right most column of a merged area should that extend beyond other data.
exclude formatted but empty cells and merged areas
The approach:
Use Range.Find to locate the last data cell
If the last column of the Used Range = Found last data cell column, return that
Else, loop from the last column of the Used Range back to the found data cell column
test for data in that column (.Count > 0), if true return that
test for merged cells in that column (IsNull(.MergeCells))
if found, loop to find the merged area
test the left most cell of the merged area for data
if found return the search column
Note
this may still be vulnerable to other "Last data" issues, eg Autofilter, Hidden rows/columns etc. I haven't tested those cases.
Has the advantage of limiting the search for merged cells to the relavent right most columns
Function MyLastCol(ws As Worksheet) As Long
Dim ur As Range
Dim lastcell As Range
Dim col As Long
Dim urCol As Range
Dim urCell As Range
Set ur = ws.UsedRange
Set lastcell = ws.Cells.Find("*", ws.Cells(1, 1), xlFormulas, , xlByColumns, xlPrevious)
For col = ur.Columns.Count To lastcell.Column - ur.Column + 2 Step -1
Set urCol = ur.Columns(col)
If Application.CountA(urCol) > 0 Then
MyLastCol = urCol.Column
Exit Function
End If
If IsNull(urCol.MergeCells) Then
For Each urCell In urCol.Cells
If urCell.MergeCells Then
If Not IsEmpty(urCell.MergeArea.Cells(1, 1)) Then
MyLastCol = urCol.Column
Exit Function
End If
End If
Next
End If
Next
MyLastCol = lastcell.Column
End Function
#Toddleson got me on the right track, here is what I ended with:
Public Sub Test_LCol()
Debug.Print Get_lCol(ActiveSheet)
End Sub
Public Function Get_lCol(WS As Worksheet) As Integer
On Error Resume Next
If Not IsWorksheetEmpty(WS) Then
Get_lCol = WS.Cells.Find(What:="*", after:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim Cell As Range
For Each Cell In WS.UsedRange
If Cell.MergeCells Then
With Cell.MergeArea
If .Cells(.Cells.Count).Column > Get_lCol Then Get_lCol = .Cells(.Cells.Count).Column
End With
End If
Next Cell
Else
Get_lCol = 1
End If
End Function
The Find Method Backed Up by the UsedRange Property: What?
Talking about wasting time...
Option Explicit
Function GetLastColumn( _
ByVal ws As Worksheet) _
As Long
If ws Is Nothing Then Exit Function
' Using the 'Find' method:
'If ws.AutoFilterMode Then ws.AutoFilterMode = False ' (total paranoia)
Dim lcCell As Range
Set lcCell = ws.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious)
If Not lcCell Is Nothing Then
GetLastColumn = lcCell.Column
End If
Debug.Print "After 'Find': " & GetLastColumn
' Using the 'UsedRange' property (paranoia):
Dim rg As Range: Set rg = ws.UsedRange
Dim clColumn As Long: clColumn = rg.Columns.Count + rg.Column - 1
If clColumn > GetLastColumn Then
If rg.Address(0, 0) = "A1" Then
If IsEmpty(rg) Then
Exit Function
End If
End If
GetLastColumn = clColumn
'Else ' clColumn is not gt GetLastColumn
End If
Debug.Print "Final (if not 0): " & GetLastColumn
End Function
Sub GetLastColumnTEST()
Debug.Print "Sub Result: " & GetLastColumn(Sheet1)
Debug.Print Sheet1.UsedRange.Address(0, 0)
End Sub
' It works for a few (?) cells, otherwise it returns 'Null'.
Sub TestMergeCells() ' Useless?! Could someone confirm.
Debug.Print Sheet1.Cells.MergeCells ' Null for sure
Debug.Print Sheet1.UsedRange.MergeCells
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

Excel VBA - How to find blank cell and sum from active cell up to blank cell

I have the following code to find the first blank cell and sum the data below it at the last blank cell.
Dim r As Range
Dim lngRowStart As Long
If Range("A1").Formula <> "" Then
lngRowStart = 1
Else
lngRowStart = Range("A1").End(xlDown).Row
End If
Set r = Cells(lngRowStart, 1).End(xlDown).Offset(1, 0)
If Left(r.Offset(-1, 0).Formula, 1) <> "=" Then
r.FormulaR1C1 = "=Subtotal(9,R[-" & r.Row - lngRowStart & "]C:R[-1]C)"
End If
But this assumes that the data is in column A and for the first set of continuous data, how to modify it for any active cell to sum the above continuous data?
For example:
2
4
3
Blank (SUM ABOVE=9)
1
3
2
Blank (SUM ABOVE=6)
You can use the UDF below (explanation inside the code's comments):
Function SumContinRange(CurCell As Range) As Double
Dim RngStart As Range, SumRng As Range
If CurCell <> "" Then
' find the first empty cell using the Find function
Set RngStart = Columns(CurCell.Column).Find(what:="", After:=CurCell, LookIn:=xlValues)
Else
' find the first empty cell using the Find function
Set RngStart = Columns(CurCell.Column).Find(what:="", After:=CurCell, LookIn:=xlValues, SearchDirection:=xlPrevious)
End If
' set the Sum Range
Set SumRng = Range(RngStart.Offset(-1, 0), RngStart.Offset(-1, 0).End(xlUp))
SumContinRange = WorksheetFunction.Sum(SumRng) ' return this value
End Function
Then, test it by passing the ActiveCell using the Sub below:
Sub TestFunc()
If ActiveCell.Value <> "" Then
ActiveCell.End(xlDown).Offset(1) = SumContinRange(ActiveCell)
Else
ActiveCell = SumContinRange(ActiveCell)
End If
End Sub

EXCEL: highlighting reoccuring data in the same column

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

EXCEL VBA Code to search cell for match to a list and delete if no match

(pic link below for this example): The data starts on row "A11", one block of data is A11 to A14, I need to search that range to see if it contains a member name from a list on sheet 2, for example Erik Christensen, if the list on sheet 2 doesnt have that name I need to delete rows A11 thru A14 and continue to the next block. The list on sheet 2 will have a varying amount of members to check so that needs to be taken into consideration. Once all the rows have been processed, I need to sorth them back to start at row A11.Please see pic and I will be extremely thankful for any help.
Sheet 1
For the below answer, I have made a few assumptions:
Your data will always start on row 11 of the first sheet in the
workbook.
The search term will always be found in the second row, below
Object:...
The data will always present in rows of 4, as shown in the picture,
with End: in the 4th row.
The list of valid names is in column A (beginning on A1) of the
second sheet in the workbook.
By "sorted back to start on row A11", I assume you mean that the
remaining blocks of data should start on row A11 and continue to the
end of the data, not that any actual sorting (i.e. by name) is
required.
This code will loop through all blocks of data (beginning with the last one, since we are deleting rows). If any of the names in column A of the second sheet appear in the block of data, that block is skipped. Otherwise, if no names appear, that block is deleted.
Sub SearchAndDeleteList()
Dim i As Long
Dim j As Long
Dim LRow As Long
Dim LListRow As Long
Dim BMatch As Boolean
'Find last instance of "End:" in
LRow = Sheets(1).Range("A:A").Find(what:="End*", searchdirection:=xlPrevious).Row
'Find last non-blank row in column A of second sheet
LListRow = Sheets(2).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayAlerts = False
Application.EnableEvents = False
If LRow >= 11 Then
'Make sure there are at least 11 rows of data
i = LRow
'MsgBox "First checkpoint: Last row of data is " & LRow 'Comment out this line
Do
BMatch = False
For j = 1 To LListRow
'Test this block to see if the value from j appears in the second row of data
If InStr(1, Sheets(1).Range("A" & i - 2).Value2, Sheets(2).Range("A" & j).Value2) > 0 Then
BMatch = True
Exit For
End If
Next j
'Application.StatusBar = "Match status for row " & i & ": " & BMatch
If Not BMatch Then
'Loop backwards to find the starting row (no lower than 11)
For j = i To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "Object:*" Then Exit For
Next j
Sheets(1).Rows(j & ":" & i).Delete
i = j - 1
Else
'Find next block
If i > 11 Then
For j = i - 1 To 11 Step -1
If Sheets(1).Range("A" & j).Value2 Like "End:*" Then Exit For
Next j
i = j
Else
i = 10 'Force the loop to exit
End If
End If
'Application.StatusBar = "Moving to row " & i
Loop Until i < 11
'Loop back through and delete any blank rows
LRow = Sheets(1).Range("A:A").Find(what:="*", searchdirection:=xlPrevious).Row
'MsgBox "Second checkpoint: new last row of data is " & LRow
For i = LRow To 11 Step -1
If Sheets(1).Range("A" & i).Value2 = vbNullString Then Sheets(1).Rows(i).Delete
Next i
End If
'Application.StatusBar = False
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
thanks to Nick's cracking actual OP's needs, I hereby propose a solution that should be more maintainable and/or changeable as per Op's future needs
Option Explicit
Sub SearchAndDeleteList2()
Dim dataSht As Worksheet
Dim dataRng As Range, namesRng As Range, cell As Range, rangeToDelete As Range
Dim firstAddress As String
'------------------------------
' setting stuff - begin
Set dataSht = ThisWorkbook.Sheets("Sheet1Data") '<== change 'data' sheet as per your needs
With dataSht
Set dataRng = .Range("A11:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
If dataRng.Rows(1).row < 11 Then Exit Sub
With ThisWorkbook.Sheets("Sheet2Names") '<== change 'names' sheet as per your needs
Set namesRng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).row)
End With
Call ApplicationSet(False, False, xlCalculationManual, False)
' setting stuff - end
'------------------------------
'------------------------------
' core code - begin
Set cell = dataRng.Find("End:", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext)
If Not cell Is Nothing Then
firstAddress = cell.Address
Do
If Not MyMatch(GetName(cell.Offset(-2)), namesRng) Then Call UpdateRngToDelete(rangeToDelete, dataSht.Rows(cell.row).Offset(-3).Resize(4))
Set cell = dataRng.FindNext(cell)
Loop While cell.Address <> firstAddress
rangeToDelete.Delete
End If
' core code - end
'------------------------------
Call ApplicationSet(True, True, xlCalculationAutomatic, True)
End Sub
Function GetName(cell As Range) As String
Dim iIni As Integer
Dim iEnd As Integer
iIni = InStr(cell.value, """") '<== the 'name' is always preceeded by '"' character
iEnd = InStr(cell.value, "\") '<== the 'name' is always follwed by '/' character
GetName = Mid(cell.value, iIni + 1, iEnd - iIni - 1)
End Function
Sub UpdateRngToDelete(baseRng As Range, toBeAddedRng As Range)
If baseRng Is Nothing Then
Set baseRng = toBeAddedRng
Else
Set baseRng = Union(baseRng, toBeAddedRng)
End If
End Sub
Function MyMatch(value As String, rng As Range) As Boolean
MyMatch = Not IsError(Application.Match(value, rng, 0))
End Function
using separate functions or subs makes it easier (and faster!) to keep control and debug future code changes

Resources