[Hỏi] Cách tách một ô thành nhiều dòng khác nhau

[bao1296]

Em có một list khoảng 2000 dòng có giá trị bất kì. Em đang muốn tách 2000 dòng này thành các dòng khác nhau, trong đó các dòng phải thoả mãn:
- Số lượng kí tự trong 1 ô tối đa là 70 kí tự
- Phải tách thành các ô có nghĩa (VD: Không được tách đôi chữ Nguyễn thành Ngu và yễn thành 2 dòng khác nhau)
- Làm cách nào để có giá trị tương ứng ở cột A với các dòng đã tách ra (VD dòng 2 sau khi tách thì được 3 dòng là 3,4,5 thì cách ô A3, A4, A5 đều có giá trị là ô A2 gốc)
Em cảm ơn mọi người ạ

Mọi người cho em hỏi thêm câu nữa ạ, là hàm find có cách nào tìm từ vị trí của một kí tự từ 1 điểm ngược lại đầu không ạ.
Ví dụ: Em muốn tìm từ vị trí 6 về vị trí 1 của đoạn text vị trí của dấu cách đầu tiên xuất hiện.
Em cảm ơn mn ạ

 

[bao1296]

Em muốn tách 1 dòng (ví dụ dòng 1) thành 4 dòng có chiều dài text bé hơn 30 mà nó không cắt chữ thành đôi (Ví dụ dòng 1 nếu đủ 30 text thì dòng 1 sẽ có thêm chữ Ph, còn chữ "ước" sẽ bị nhảy xuống dòng 2, nên sẽ chỉ cắt ở các vị trí trước dấu cách hoặc sau chữ cách.
Ví dụ: Võ An Phước thì sẽ chỉ cắt ở các vị trí dấu cách giữa các chữ "Võ" "An" "Phước" và sao cho số lượng text tối đa trong 1 dòng là 30

 

[batman1]

Code chưa phục vụ lỗi, chưa tối ưu nếu có thể. Nếu cần thì tự làm.
Nếu cần tách max 70 ký tự thì sửa maxlen ở đầu code. Không cần đánh số thứ tự ở cột A, code tự đánh số. Dữ liệu từ B1.

Hàm bạn hỏi là InStrRev

Sub splitText()
Const maxlen = 30
Dim r As Long, k As Long, curr_pos As Long, text As String, data(), result()
    With ThisWorkbook.Worksheets("Sheet1")
'        xoa ket qua cu
        .Range("C1:D1").Resize(.Cells(Rows.count, "D").End(xlUp).Row).ClearContents
        r = .Cells(Rows.count, "B").End(xlUp).Row
        data = .Range("B1:B" & r + 1).Value
    End With
    For r = 1 To UBound(data) - 1
        text = Replace(Trim(data(r, 1)), Chr(10), ", ")
        Do While Len(text) > maxlen
            curr_pos = curr_pos + 1
            ReDim Preserve result(1 To 2, 1 To curr_pos)
            k = InStrRev(text, " ", maxlen + 1)
            result(1, curr_pos) = r
            result(2, curr_pos) = Mid(text, 1, k - 1)
            text = Mid(text, k + 1)
        Loop
        curr_pos = curr_pos + 1
        ReDim Preserve result(1 To 2, 1 To curr_pos)
        result(1, curr_pos) = r
        result(2, curr_pos) = text
    Next r
    ThisWorkbook.Worksheets("Sheet1").Range("C1:D1").Resize(UBound(result, 2)).Value = Application.Transpose(result)
End Sub