Option Explicit
Sub SpecialSort()
'JBeaucaire (12/26/2009)
Dim r As Long, NC As Long
Dim x As Long, y As Long
Dim rfind As Range
x = Range("A1").SpecialCells(xlCellTypeLastCell).Row
y = Range("A1").SpecialCells(xlCellTypeLastCell).Column
NC = y + 2
On Error Resume Next
For r = 1 To x
Set rfind = Range(Cells(r, 1), Cells(r, y)).Find("string1", After:=Cells(r, y), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rfind Is Nothing Then Range(rfind, rfind.Offset(0, 1)).Copy Cells(r, NC)
Set rfind = Range(Cells(r, 1), Cells(r, y)).Find("string2", After:=Cells(r, y), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rfind Is Nothing Then Range(rfind, rfind.Offset(0, 1)).Copy Cells(r, NC + 2)
Set rfind = Range(Cells(r, 1), Cells(r, y)).Find("string3", After:=Cells(r, y), LookIn:=xlValues, _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not rfind Is Nothing Then Range(rfind, rfind.Offset(0, 1)).Copy Cells(r, NC + 4)
Next r
Range("A1", Cells(x, y + 1)).Delete xlShiftToLeft
End Sub
Bookmarks