Tách dữ liệu trong 01 ô ra nhiều cột (2 người xem)

[10hkem]

Em chào các anh chị em trong diễn đàn.
Em có file dữ liệu như file đính kèm cần tách ra nhiều cột, anh chị nào có thể giúp em được không ạ. em cảm ơn.

 

[HeSanbi]

Em chào các anh chị em trong diễn đàn.
Em có file dữ liệu như file đính kèm cần tách ra nhiều cột, anh chị nào có thể giúp em được không ạ. em cảm ơn.

Cái dữ liệu đánh bị sai hơi nhiều đấy: Bà: <> Bà;
Không tách dòng
Ông: ... Bà:...
Thứ tự 71 -> 73

Xem lại dữ liệu nếu lỗi báo nhé

Sub Tach()
[M6:X512].Value = ""
Dim Arr, dArr, i, str1() As String, str2() As String
Arr = [A6:K512].Value
ReDim dArr(1 To UBound(Arr), 1 To UBound(Arr, 2) + 2)

For i = 1 To UBound(Arr)
    If Arr(i, 2) <> "" Then
        On Error Resume Next
        If Arr(i, 2) Like "Ông*" And Arr(i, 2) Like "*Bà*" Then
            Arr(i, 2) = Replace(Arr(i, 2), ";", ":")
            str1 = Split(Arr(i, 2), "Bà:")
            str2 = Split(Arr(i, 3), Chr(10))
            dArr(i, 1) = Application.WorksheetFunction.Clean(Trim(Replace(str1(0), "Ông:", "")))
            dArr(i, 2) = Application.WorksheetFunction.Clean(Trim(str2(0)))
            dArr(i, 3) = Application.WorksheetFunction.Clean(Trim(str1(1)))
            dArr(i, 4) = Application.WorksheetFunction.Clean(Trim(str2(1)))
        Else
            If Arr(i, 2) Like "Ông*" Or Arr(i, 2) Like "Bà*" Then
                Arr(i, 2) = Replace(Arr(i, 2), ";", ":")
                If UCase(Left(Arr(i, 2), 1)) = "B" Then
                    dArr(i, 3) = Application.WorksheetFunction.Clean(Trim(Replace(Arr(i, 2), "Bà:", "")))
                    dArr(i, 4) = Application.WorksheetFunction.Clean(Trim(Arr(i, 3)))
                Else
                    dArr(i, 1) = Application.WorksheetFunction.Clean(Trim(Replace(Arr(i, 2), "Ông:", "")))
                    dArr(i, 2) = Application.WorksheetFunction.Clean(Trim(Arr(i, 3)))
                End If
            End If
        End If
    End If
Next
[Q6:X512].Value = [D6:K512].Value
[M6].Resize(UBound(Arr), 4) = dArr
End Sub

 

[befaint]

https://www.giaiphapexcel.com/diend...-ra-thành-nhiều-dòng.53248/page-4#post-888263

 

[10hkem]

Cái dữ liệu đánh bị sai hơi nhiều đấy: Bà: <> Bà;
Không tách dòng
Ông: ... Bà:...
Thứ tự 71 -> 73

Xem lại dữ liệu nếu lỗi báo nhé

Sub Tach()
[M6:X512].Value = ""
Dim Arr, dArr, i, str1() As String, str2() As String
Arr = [A6:K512].Value
ReDim dArr(1 To UBound(Arr), 1 To UBound(Arr, 2) + 2)

For i = 1 To UBound(Arr)
    If Arr(i, 2) <> "" Then
        On Error Resume Next
        If Arr(i, 2) Like "Ông*" And Arr(i, 2) Like "*Bà*" Then
            Arr(i, 2) = Replace(Arr(i, 2), ";", ":")
            str1 = Split(Arr(i, 2), "Bà:")
            str2 = Split(Arr(i, 3), Chr(10))
            dArr(i, 1) = Application.WorksheetFunction.Clean(Trim(Replace(str1(0), "Ông:", "")))
            dArr(i, 2) = Application.WorksheetFunction.Clean(Trim(str2(0)))
            dArr(i, 3) = Application.WorksheetFunction.Clean(Trim(str1(1)))
            dArr(i, 4) = Application.WorksheetFunction.Clean(Trim(str2(1)))
        Else
            If Arr(i, 2) Like "Ông*" Or Arr(i, 2) Like "Bà*" Then
                Arr(i, 2) = Replace(Arr(i, 2), ";", ":")
                If UCase(Left(Arr(i, 2), 1)) = "B" Then
                    dArr(i, 3) = Application.WorksheetFunction.Clean(Trim(Replace(Arr(i, 2), "Bà:", "")))
                    dArr(i, 4) = Application.WorksheetFunction.Clean(Trim(Arr(i, 3)))
                Else
                    dArr(i, 1) = Application.WorksheetFunction.Clean(Trim(Replace(Arr(i, 2), "Ông:", "")))
                    dArr(i, 2) = Application.WorksheetFunction.Clean(Trim(Arr(i, 3)))
                End If
            End If
        End If
    End If
Next
[Q6:X512].Value = [D6:K512].Value
[M6].Resize(UBound(Arr), 4) = dArr
End Sub

Bài đã được tự động gộp: 29/10/18

Em cảm ơn anh đã giúp đỡ ạ.

Bài đã được tự động gộp: 29/10/18

Cái dữ liệu đánh bị sai hơi nhiều đấy: Bà: <> Bà;
Không tách dòng
Ông: ... Bà:...
Thứ tự 71 -> 73

Xem lại dữ liệu nếu lỗi báo nhé

Sub Tach()
[M6:X512].Value = ""
Dim Arr, dArr, i, str1() As String, str2() As String
Arr = [A6:K512].Value
ReDim dArr(1 To UBound(Arr), 1 To UBound(Arr, 2) + 2)

For i = 1 To UBound(Arr)
    If Arr(i, 2) <> "" Then
        On Error Resume Next
        If Arr(i, 2) Like "Ông*" And Arr(i, 2) Like "*Bà*" Then
            Arr(i, 2) = Replace(Arr(i, 2), ";", ":")
            str1 = Split(Arr(i, 2), "Bà:")
            str2 = Split(Arr(i, 3), Chr(10))
            dArr(i, 1) = Application.WorksheetFunction.Clean(Trim(Replace(str1(0), "Ông:", "")))
            dArr(i, 2) = Application.WorksheetFunction.Clean(Trim(str2(0)))
            dArr(i, 3) = Application.WorksheetFunction.Clean(Trim(str1(1)))
            dArr(i, 4) = Application.WorksheetFunction.Clean(Trim(str2(1)))
        Else
            If Arr(i, 2) Like "Ông*" Or Arr(i, 2) Like "Bà*" Then
                Arr(i, 2) = Replace(Arr(i, 2), ";", ":")
                If UCase(Left(Arr(i, 2), 1)) = "B" Then
                    dArr(i, 3) = Application.WorksheetFunction.Clean(Trim(Replace(Arr(i, 2), "Bà:", "")))
                    dArr(i, 4) = Application.WorksheetFunction.Clean(Trim(Arr(i, 3)))
                Else
                    dArr(i, 1) = Application.WorksheetFunction.Clean(Trim(Replace(Arr(i, 2), "Ông:", "")))
                    dArr(i, 2) = Application.WorksheetFunction.Clean(Trim(Arr(i, 3)))
                End If
            End If
        End If
    End If
Next
[Q6:X512].Value = [D6:K512].Value
[M6].Resize(UBound(Arr), 4) = dArr
End Sub

Em cảm ơn anh ạ.

 

[10hkem]

Em chào các anh chị.
Xin phép được làm phiền các anh chị lần nữa. Em xin đoạn code cho file Excel đính kèm phía dưới. Mong các anh chị bớt chút thời gian chỉ bảo.