nhờ giúp đỡ Code VBA (1 người xem)

[swalowbird]

Hi các bác , e làm code phân giải chuỗi ký tự để có dấu /
và đang tắc chỗ k> 2 , giúp em về thuật toán và code với
thanks !
Em muốn làm file code mà từ 1 chuỗi ký tự như

[TABLE="class: cms_table, width: 254"]
[TR]
[TD]000320/2B6/467/237/990/123/ACF12
sau khi bấm button sẽ ínsert thành các dòng bên duoi[/TD]
[/TR]
[/TABLE]

000320
0002B6
000467
000237
000990
000123
0ACF12

Option Explicit
Sub GPE()
Dim MyString, TargetString As String, LenTH1 As Integer
Dim Rng As Range, Arr() As Integer
Dim K As Integer, I As Integer, J As Integer, N As Integer, W As Byte '*|*'
Set Rng = Selection
MyString = Rng
TargetString = "/" 'Cái Này Ta Có The Khai Báo 1 Hàng Mà Dùng'
LenTH1 = Len(MyString)
ReDim Arr(1 To LenTH1) As Integer
J = 0
For I = 1 To LenTH1
If Mid(MyString, I, 1) = TargetString Then
J = J + 1
End If
Next I
K = J
For I = 1 To LenTH1
If Mid(MyString, I, 1) = TargetString Then
W = W + 1 '*|*'
Arr(W) = I '*|*'
MsgBox Arr(W), , "Thong Bao 02"
End If
Next I
If K = 1 Then
Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - 1)
Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - (LenTH1 - Arr(1)) - 1) & Mid(MyString, Arr(1) + 1, LenTH1 - Arr(1))
End If
If K = 2 Then
If Arr(2) - Arr(1) - 1 <= LenTH1 - Arr(2) Then
Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - 1)

Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - Arr(2) + Arr(1)) & Mid(MyString, Arr(1) + 1, Arr(2) - Arr(1) - 1)

Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - LenTH1 + Arr(2) - 1) & Mid(MyString, Arr(2) + 1, LenTH1 - Arr(2))

Else
Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - 1)

Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - Arr(2) + Arr(1)) & Mid(MyString, Arr(1) + 1, Arr(2) - Arr(1) - 1)

Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - Arr(2) + Arr(1)) & Mid(MyString, Arr(1) + 1, Arr(2) - Arr(1) - LenTH1 + Arr(2) - 1) & Mid(MyString, Arr(2) + 1, LenTH1 - Arr(2))

End If
If K > 2 Then

If Arr(W) - Arr(W - 1) >= Arr(W - 1) - Arr(W - 2) Then
W = 3
Do While Arr(W) - Arr(W - 1) >= Arr(W - 1) - Arr(W - 2)
Rng.EntireRow.copy
Rng.Offset(1, 0).EntireRow.insert Shift:=xlDown
Rng.Offset(1, 0) = Mid(MyString, 1, Arr(1) - 1 - Arr(W) + Arr(W - 1)) & Mid(MyString, Arr(W) + 1, Arr(W + 1) - Arr(W))
W = W + 1
Loop
End If

End If


Application.CutCopyMode = False '*|*'
End If


End Sub

 

[swalowbird]

Bác làm cũng siêu vãi !
Nhưng bác có thể sửa code để nó sau khi phân giải 1 ô , sẽ tự insert 1 dòng xuống thế này ko a, giúp e nhé !!

Thanks !!!!

 

[tamhoang.pm]

Của bạn đây, lần sau ghi rõ yêu cầu từ đầu bạn nhé

 

[RoberLiem]

Xem thử file này coi sao.
Muốn kết quả nằm ở đâu thì bạn tuỳ chỉnh lại.

 

[swalowbird]

Hi bác !
giải thích em thuật toán này được không vầy ??
Ảo diệu quá !!

Thanks !!!

For J = 0 To UBound(Tem)
K = K + 1
Hic = Left(Hic, Len(Hic) - Len(Tem(J))) & Tem(J)
dArr(K, 1) = Hic