Sub XYZ()
Dim Arr(), Arr2(), Res() As String, t
Dim i&, i2&, k&, k2&, sR&, sR2&, sRow&, ma$, ma2$
t = Timer
With Sheet1
Arr = .Range("B3", .Range("B" & Rows.Count).End(xlUp)).Value
Arr2 = .Range("D3", .Range("D" & Rows.Count).End(xlUp)).Value
End With
Call SortArrayList(Arr, Arr)
Call SortArrayList(Arr2, Arr2)
sR = UBound(Arr): sR2 = UBound(Arr2)
If sR > sR2 Then sRow = sR Else sRow = sR2
ReDim Res(1 To sRow, 1 To 2)
i = 1: i2 = 1
ma = Arr(i, 1): ma2 = Arr2(i2, 1)
Do
If ma Like ma2 & "*" Or ma2 Like ma & "*" Then
Arr(i, 1) = Empty: Arr2(i2, 1) = Empty
If i = sR Or i2 = sR2 Then Exit Do
i = i + 1: i2 = i2 + 1
ma = Arr(i, 1): ma2 = Arr2(i2, 1)
Else
If ma > ma2 Then
If i2 = sR2 Then Exit Do
i2 = i2 + 1: ma2 = Arr2(i2, 1)
Else
If i = sR Then Exit Do
i = i + 1: ma = Arr(i, 1)
End If
End If
Loop
For i = 1 To sR
If Arr(i, 1) <> Empty Then
k = k + 1
Res(k, 1) = StrReverse(Arr(i, 1))
End If
Next i
For i2 = 1 To sR2
If Arr2(i2, 1) <> Empty Then
k2 = k2 + 1
Res(k2, 2) = StrReverse(Arr2(i2, 1))
End If
Next i2
With Sheet1
i = .Range("G" & Rows.Count).End(xlUp).Row
i2 = .Range("H" & Rows.Count).End(xlUp).Row
If i2 > i Then i = i2
If i > 2 Then .Range("G3").Resize(i, 2).ClearContents
If k2 > k Then k = k2
If k > 0 Then .Range("F3").Resize(k, 2).Value = Res
End With
MsgBox ("Thoi gian chay code: " & Timer - t & "giay")
End Sub
Private Sub SortArrayList(ByRef ResSort As Variant, ByVal sArrSort As Variant)
Dim oArrList As Object, iKey$, i&, k&, fRow&, eRow&
Set oArrList = CreateObject("System.Collections.ArrayList")
fRow = LBound(sArrSort, 1): eRow = UBound(sArrSort, 1)
ReDim ResSort(1 To eRow - fRow + 1, 1 To 1)
For i = fRow To eRow
iKey = sArrSort(i, 1)
'If iKey <> Empty Then oArrList.Add iKey
If iKey <> Empty Then oArrList.Add StrReverse(iKey)
Next i
oArrList.Sort
eRow = oArrList.Count - 1
For i = 0 To eRow
k = k + 1
ResSort(k, 1) = oArrList.Item(i)
Next i
Set oArrList = Nothing
End Sub
