Em nhờ mọi người giúp em tách và ghép chuỗi với ạ!

[maixuanvuong276]

Mong mọi người giúp em,kết quả em kèm theo file ạ! em xin cảm ơn!

 

[CHAOQUAY]

Mong mọi người giúp em,kết quả em kèm theo file ạ! em xin cảm ơn!

Chạy code dưới đây

Option Explicit

Sub xxx()
Dim S
Dim Kq
Dim i, j, k, t
With Sheet1
    k = Len(.Range("B4"))
    ReDim S(1 To k)
    For j = 1 To k
        S(j) = Mid(.Range("B4"), j, 1)
    Next j
    ReDim Kq(1 To k * (k + 1) / 2)
    For i = 1 To k - 1
        For j = i + 1 To k
            t = t + 1
            Kq(t) = S(i) & S(j)
        Next j
    Next i
    .Range("E5").Resize(1, UBound(Kq)) = Kq
End With
End Sub

 

[maixuanvuong276]

Chạy code dưới đây

Option Explicit

Sub xxx()
Dim S
Dim Kq
Dim i, j, k, t
With Sheet1
    k = Len(.Range("B4"))
    ReDim S(1 To k)
    For j = 1 To k
        S(j) = Mid(.Range("B4"), j, 1)
    Next j
    ReDim Kq(1 To k * (k + 1) / 2)
    For i = 1 To k - 1
        For j = i + 1 To k
            t = t + 1
            Kq(t) = S(i) & S(j)
        Next j
    Next i
    .Range("E5").Resize(1, UBound(Kq)) = Kq
End With
End Sub

Dạ em cảm ơn anh nhiều ạ!

 

[bebo021999]

Thử đỡ củ chuối này trong khi chờ phương án khác:

Option Explicit
Sub tach()
Dim i&, j&, k&
Dim arr(1 To 1, 1 To 1000)
    For i = 1 To Len(Range("B4")) - 1
        For j = i + 1 To Len(Range("B4"))
            k = k + 1
            arr(1, k) = Range("B4").Characters(i, 1).Text & Range("B4").Characters(j, 1).Text
        Next
    Next
Range("E5").Resize(1, 1000) = arr
End Sub