Nhờ giúp đỡ code tách dữ liệu và chèn xuống các dòng tiếp theo (1 người xem)

[Shaa]

Chào các bác,
Em đang có một bài toán, cần tách các chuỗi (ngăn cách nhau bởi dấu "/" ) và chèn tương ứng xuống dòng tiếp theo
Em có mô tả ví dụ và kết quả chi tiết trong tệp đính kèm ạ
Nhờ các bác giúp đỡ code ạ

 

[HUONGHCKT]

Chào các bác,
Em đang có một bài toán, cần tách các chuỗi (ngăn cách nhau bởi dấu "/" ) và chèn tương ứng xuống dòng tiếp theo
Em có mô tả ví dụ và kết quả chi tiết trong tệp đính kèm ạ
Nhờ các bác giúp đỡ code ạ

Tham khảo code củ chuối này nhé:

Option Explicit

Sub Tach()
Dim i&, j&, Lr, t&, R&
Dim Arr(), KQ(), S
With Sheet1
    Lr = .Range("A10000").End(xlUp).Row
    Arr = .Range("A3:E" & Lr).Value
End With
R = UBound(Arr)
ReDim KQ(1 To R * 100, 1 To 5)
For i = 1 To R
    S = Split(Arr(i, 3), "/")
        For j = LBound(S) To UBound(S)
            t = t + 1
            KQ(t, 1) = Arr(i, 1)
            KQ(t, 2) = Arr(i, 2)
            KQ(t, 3) = S(j)
            KQ(t, 4) = Arr(i, 4)
            KQ(t, 5) = Arr(i, 5)
        Next j
Next i
If t Then
    With Sheets("KQ")
        .Range("A3:E10000").ClearContents
        .Range("A3:E10000").Borders.LineStyle = xlNone
        .Range("A3").Resize(t, 5) = KQ
        .Range("A3").Resize(t, 5).Borders.LineStyle = 1
    End With
End If
MsgBox "Done"
End Sub

 

[Shaa]

Tham khảo code củ chuối này nhé:

Option Explicit

Sub Tach()
Dim i&, j&, Lr, t&, R&
Dim Arr(), KQ(), S
With Sheet1
    Lr = .Range("A10000").End(xlUp).Row
    Arr = .Range("A3:E" & Lr).Value
End With
R = UBound(Arr)
ReDim KQ(1 To R * 100, 1 To 5)
For i = 1 To R
    S = Split(Arr(i, 3), "/")
        For j = LBound(S) To UBound(S)
            t = t + 1
            KQ(t, 1) = Arr(i, 1)
            KQ(t, 2) = Arr(i, 2)
            KQ(t, 3) = S(j)
            KQ(t, 4) = Arr(i, 4)
            KQ(t, 5) = Arr(i, 5)
        Next j
Next i
If t Then
    With Sheets("KQ")
        .Range("A3:E10000").ClearContents
        .Range("A3:E10000").Borders.LineStyle = xlNone
        .Range("A3").Resize(t, 5) = KQ
        .Range("A3").Resize(t, 5).Borders.LineStyle = 1
    End With
End If
MsgBox "Done"
End Sub

Em thử thấy kết quả đúng rồi bác ạ
em cảm ơn bác nhiều ạ