Sub SeqToClip_V2()
Dim fRange As Range, kArea As Range
Dim fArr As String, I As Long, cFilt, J As Long
Set fRange = Range(Range("D1"), Range("D1").End(xlDown).Offset(0, 1))
For I = 16 To 1000
cFilt = Cells(I, "J").Value
If Len(cFilt) = 0 Then Exit For
fArr = ""
For J = 1 To fRange.Rows.Count
If fRange.Cells(J, 1).Value = cFilt Then
fArr = fArr & fRange.Cells(J, 1).Value & " - " & fRange.Cells(J, 2).Value & vbCrLf
End If
Next J
DoEvents
If Len(fArr) > 2 Then
fArr = fArr & fRange.Cells(J + 1, 1).Value & " - " & fRange.Cells(J + 1, 2).Value & vbCrLf
fArr = fArr & fRange.Cells(J + 2, 1).Value & " - " & fRange.Cells(J + 2, 2).Value & vbCrLf
SetClipBoardText (fArr)
Beep
MsgBox ("Copy the clipboard data into WhatsApp Web; destination: " & Cells(I, "J").Value)
End If
Next I
MsgBox ("Completed")
End Sub