允許原數據的第1行有標題、或者沒有標題。
註意在代碼中打了括號的地方，需要修改。
Sub 每兩列刪除重復項()
Dim dic As Object, sht As Worksheet, i&, icol%, irow&, arr
Set sht = ActiveSheet
Set dic = CreateObject("scripting.dictionary") '創建字典
Worksheets.Add After:=Sheets(Sheets.Count) '新建工作表放到最後
ActiveSheet.Name = Format(Now, "yyyymmdd-hhmmss") '工作表命名
For icol = Columns("A").Column To Columns("Z").Column Step 2 '遍歷在此行：修改列號範圍
irow = sht.Cells(Rows.Count, icol).End(3).Row
arr = sht.Cells(1, icol).Resize(irow, 2)
For i = LBound(arr) To UBound(arr)
dic(arr(i, 1) & "/" & arr(i, 2)) = 1 '寫入字典
Next
'輸出
Cells(1, icol).Resize(dic.Count, 1) = Application.Transpose(dic.keys) '輸入本組去重復後的數據
Columns(icol).TextToColumns Destination:=Cells(1, icol), Other:=True, OtherChar:="/" '按斜杠分列
'排序
ActiveSheet.Sort.SortFields.Clear
ActiveSheet.Sort.SortFields.Add2 Key:=Cells(1, icol + 1).Resize(dic.Count, 1) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
.SetRange Cells(1, icol).Resize(dic.Count, 2)
.Header = xlYes '第1行有標題若第1行不是標題，在此行：把xlYes改為xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'清空
Erase arr '清空數組
dic.RemoveAll '清空字典
Next
MsgBox "處理完畢！", , "提示"
End Sub