Sub sosanhsapxep()
Dim Arr1 As Variant, Arr2 As Variant
Dim ListR() As Integer
Dim MyString As String
Dim Result As Variant
Dim i As Integer, j As Integer, k As Integer, x, z
Arr1 = Sheet1.Range("a1:a4")
Arr2 = Sheet1.Range("b1:c3")
Result = Arr1
ReDim Preserve Result(1 To UBound(Arr1), 1 To 3)
For i = 1 To UBound(Arr2)
ReDim ListR(1 To UBound(Arr1))
MyString = Mid(Arr2(i, 1), 1, 1)
k = 0
For j = 1 To UBound(Arr1)
If Left(Arr1(j, 1), 1) = MyString Then
k = k + 1
ListR(k) = j
End If
Next j
If k > 0 Then
z = 2
Do While k > 0
ReDim Preserve ListR(1 To k)
MyString = Mid(Arr2(i, 1), z, 1)
k = 0
For Each x In ListR
If z < Len(Arr1(x, 1)) + 1 Then
If Mid(Arr1(x, 1), z, 1) = MyString Then
k = k + 1
ListR(k) = x
End If
End If
Next x
z = z + 1
Loop
End If
Result(ListR(1), 2) = Arr2(i, 1)
Result(ListR(1), 3) = Arr2(i, 2)
Next i
Sheet1.Range("a12").Resize(UBound(Result), UBound(Result, 2)) = Result
End Sub
