Need This Macro to Run Only On Cells That Are Black

[supergravy]

I currently use a macro that extracts data from a column and produces my desired result.

For example, it finds the keyword I am looking for in column B and paste a keyword I want it to say in Column Z

I want to know if there is a way I can get this macro to run on only the blank cells in Column Z.

This is the macro I currently use:-

Sub ExtractSpecificDataFromCell()

Dim oBook As Workbook
Dim dBook As Workbook
Dim sTrVal As String
Dim Str1Val As String
Dim Str2Val As String
Dim Str3Val As String
Dim Str4Val As String
Dim Str5Val As String

Dim Rng As Range
Dim Cell As Range
Dim sStr As String

Application.ScreenUpdating = False

Sheets("Data").Activate

Range("a2").Select
'Do Until IsEmpty(Cells(ActiveCell.Row, "a"))

sTrVal = Sheets("Data").Range("A2").Value
Str1Val = Sheets("Data").Range("A3").Value
Str2Val = Sheets("Data").Range("A4").Value
Str3Val = Sheets("Data").Range("A5").Value
Str4Val = Sheets("Data").Range("A6").Value
Str5Val = Sheets("Data").Range("A7").Value

sTrValOutput = Sheets("Data").Range("B2").Value
sTr1ValOutput = Sheets("Data").Range("B3").Value
sTr2ValOutput = Sheets("Data").Range("B4").Value
sTr3ValOutput = Sheets("Data").Range("B5").Value
sTr4ValOutput = Sheets("Data").Range("B6").Value
sTr5ValOutput = Sheets("Data").Range("B7").Value

Sheets("Results").Activate

lastrow = Cells(Rows.Count, "b").End(xlUp).Row

Set Rng = Range(Range("b2"), Range("b2").End(xlDown)).Offset(0, 25)
For Each Cell In Rng
sStr = UCase(Cell.Offset(0, -25).Value)
Select Case True
Case InStr(1, sStr, sTrVal, vbTextCompare) <> 0
sSt = sTrValOutput
Case InStr(1, sStr, Str1Val, vbTextCompare) <> 0
sSt = sTr1ValOutput
Case InStr(1, sStr, Str2Val, vbTextCompare) <> 0
sSt = sTr2ValOutput
Case InStr(1, sStr, Str3Val, vbTextCompare) <> 0
sSt = sTr3ValOutput
Case InStr(1, sStr, Str4Val, vbTextCompare) <> 0
sSt = sTr4ValOutput
Case InStr(1, sStr, Str5Val, vbTextCompare) <> 0
sSt = sTr5ValO


Case Else
sSt = ""
End Select
Cell.Value = sSt
'End If
Next

 

[Logit]

My mind isn't running too well this morning ... but if I understand what you are seeking:

Set Rng = Range(Range("b2"), Range("b2").End(xlDown)).Offset(0, 25)
For Each Cell In Rng
sStr = UCase(Cell.Offset(0, -25).Value)
Select Case True
Case InStr(1, sStr, sTrVal, vbTextCompare) <> 0       '<--- change from    <> 0    to     = ""
sSt = sTrValOutput
Case InStr(1, sStr, Str1Val, vbTextCompare) <> 0       '<--- change from    <> 0    to     = ""
sSt = sTr1ValOutput
Case InStr(1, sStr, Str2Val, vbTextCompare) <> 0       '<--- change from    <> 0    to     = ""
sSt = sTr2ValOutput
Case InStr(1, sStr, Str3Val, vbTextCompare) <> 0       '<--- change from    <> 0    to     = ""
sSt = sTr3ValOutput
Case InStr(1, sStr, Str4Val, vbTextCompare) <> 0       '<--- change from    <> 0    to     = ""
sSt = sTr4ValOutput
Case InStr(1, sStr, Str5Val, vbTextCompare) <> 0       '<--- change from    <> 0    to     = ""
sSt = sTr5ValO