Sub colorme()
Dim wshrpt As Worksheet
Dim wshcore As Worksheet
Dim iy As Integer 'how many DT's
Dim llastrow As Integer
Dim rdata As Range
Dim fWhat As String
Dim vA As Variant
Dim Ct As Long
Dim r As Range
Const InstanceNumber As Long = 1
Set wshrpt = Worksheets("RPL")
Set wshcore = Worksheets("CONTROL_1")
fWhat = "Kelcey"
llastrow = wshrpt.Range("R" & Rows.Count).End(xlUp).Row
Set rdata = wshrpt.Range("R13:R" & llastrow)
iy = Application.CountIf(rdata, "DT")
'MsgBox iy
For t = 1 To iy
LastRowOfDT = rdata.Find("DT", searchdirection:=xlPrevious, LookIn:=xlValues, lookat:=xlWhole).Row
RID = wshrpt.Range("A" & LastRowOfDT)
RIDrow = wshcore.Range("A:A").Find(RID, searchdirection:=xlPrevious, LookIn:=xlValues, lookat:=xlWhole).Row
MsgBox "Last DT at ROW: " & LastRowOfDT & Chr(13) & "RID: " & RID & " " & RIDrow
'Worksheets("RPL").Rows(LastRowOfD).Insert
irelines = Application.CountIf(wshrpt.Range("M" & LastRowOfDT & ":P" & LastRowOfDT), fWhat)
'MsgBox irelines
LastRowOfD = rdata.Find("D*", searchdirection:=xlPrevious, LookIn:=xlValues, lookat:=xlWhole).Row + 1
For x = 1 To irelines
With wshrpt
.Rows(LastRowOfDT).EntireRow.Copy
.Rows(LastRowOfD).Insert
With .Range("H" & LastRowOfD & ":L" & LastRowOfD)
.Value = ""
.Interior.ColorIndex = 15
End With
If x = 1 Then
With .Range("N" & LastRowOfD & ":P" & LastRowOfD)
.Value = ""
.Interior.ColorIndex = 15
End With
With wshcore.Range("BM" & RIDrow & ":CR" & RIDrow)
vA = .Value
For i = LBound(vA, 2) To UBound(vA, 2)
If InStr(vA(1, i), fWhat) > 0 Then
Ct = Ct + 1
If Ct = InstanceNumber Then
MsgBox "Instance number " & InstanceNumber & "found in cell " & .Cells(1, i).Address
MsgBox .Cells(1, i).Offset(0, -2).Value
With wshrpt
.Range("B" & LastRowOfD) = .Cells(1, i).Offset(0, -2).Value
End With
Exit Sub
End If
End If
Next i
MsgBox "Only " & Ct & " instances of " & fWhat & " were found."
End With
ElseIf x = 2 Then
With .Range("M" & LastRowOfD, "O" & LastRowOfD & ":P" & LastRowOfD)
.Value = ""
.Interior.ColorIndex = 15
End With
' Repeat blue code: Instance Number 2
ElseIf x = 3 Then
With .Range("M" & LastRowOfD & ":N" & LastRowOfD, "P" & LastRowOfD)
.Value = ""
.Interior.ColorIndex = 15
End With
' Repeat blue code: Instance Number 3
Else 'x = 4 Then
With .Range("M" & LastRowOfD & ":O" & LastRowOfD)
.Value = ""
.Interior.ColorIndex = 15
End With
' Repeat blue code: Instance Number 4
End If
'.Rows(LastRowOfD).PasteSpecial
End With
Next x
Next t
End Sub