Loop through code, move across a columns

I have recorded a macro but it's pretty long. It's basically: At source Sheet1, select copy from col B, move to Sheet5 sort and remove duplicates and paste in col A. Then repeat loop but this time move across one column at source B to C and return to Sheet 5 and paste two cols over from previous Col C to E. Repeat loop.

So, it's shunting across one column at source and two columns at destination sheet, each loop. The source sheet starts at col B and ends at col Y. The destination sheet starts at col A and finishes at col AU. Code attached for two cycles of the loop.

Thanks for reading :)

#Sub Criteriadropdownpaste()
'
' Criteriadropdownpaste Macro
'
'
Sheets("Sheet1").Select
Range("B3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet5").Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("A2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet5").Sort
.SetRange Range("A2:A20000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$A$1:$A$20000").RemoveDuplicates Columns:=1, Header:= _
xlYes
Sheets("Sheet1").Select
Range("C3").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Sheet5").Select
Range("C2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet5").Sort.SortFields.Add Key:=Range("C2"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet5").Sort
.SetRange Range("C2:C20000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveSheet.Range("$C$1:$C$20000").RemoveDuplicates Columns:=1, Header:= _
xlYes#

try this but make sure that sheet 5 is clear first:

Code:

---

Sub blah()
With Sheets("Sheet5")
  For Each cll In Sheets("Sheet1").Range("B3:Y3").Cells
    Set Destn = .Cells(2, cll.Column * 2 - 3)
    Sheets("Sheet1").Range(cll, cll.End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Destn, Unique:=True
    With .Sort
      .SortFields.Clear
      .SortFields.Add Key:=Destn, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange Range(Destn, Destn.End(xlDown))
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .SortMethod = xlPinYin
      .Apply
    End With
  Next cll
End With
End Sub

---

A genius no more Pascal, a SUPER GENIUS, by any other name. You've conquered again, well done.

Thanks sooo much :) Case closed