Sub ABC()
Dim arr(), S, res(), sRow&, i&, j&, L&, fC&, eC&, ch$
arr = Range("A1", Range("A1000000").End(xlUp)).Value
sRow = UBound(arr)
ReDim res(1 To sRow, 1 To 2)
For i = 1 To sRow
L = Len(arr(i, 1))
fC = L + 1
For j = 1 To L
ch = Mid(arr(i, 1), j, 1)
If ch <> Empty Then
If AscW(ch) < 0 Then
If fC > j Then fC = j
eC = j
End If
End If
Next j
If fC < L + 1 Then
res(i, 1) = Mid(arr(i, 1), fC, eC - fC + 1)
res(i, 2) = Replace(arr(i, 1), res(i, 1), "")
End If
Next i
Range("C1").Resize(sRow, 2) = res
End Sub