Tách dữ liệu trong 01 ô (dòng) ra thành nhiều dòng!

[nguyensatran]

Dữ liệu của bạn không đồng nhất 2 cột mà cũng không phải là chia theo xuống dòng.Bạn xem lại nhé.Còn code mình viết đây.

Sub tach()
    Dim arr, i As Long, lr As Long, T, kq, a As Long, R As Long, L As Long, T1, k As Integer, j As Integer
    With Sheets("nguon")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         arr = .Range("B5:O" & lr).Value
         R = UBound(arr)
         L = UBound(arr, 2)
         If R * 10 > Rows.Count Then a = Rows.Count Else a = R * 10
         ReDim kq(1 To a, 1 To L)
         a = 0
    End With
        For i = 1 To R
            T = Split(Chr(10) & arr(i, 9), Chr(10))
           ' T1 = Split(Chr(10) & arr(i, 10), Chr(10))
            For k = 1 To UBound(T)
                If Len(T(k)) > 0 Then
                   a = a + 1
                   For j = 1 To L
                       kq(a, j) = arr(i, j)
                   Next j
                        kq(a, 9) = T(k)
                        'kq(a, 10) = T1(k)
                End If
            Next k
       Next i
    With Sheets("cach2")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 4 Then .Range("B5:O" & lr).ClearContents
         If a Then .Range("B5:o5").Resize(a).Value = kq
    End With
End Sub

Cám ơn anh đã giúp em
Do em mới vào công ty và được bàn giao dữ liệu yêu cầu tách dòng ở 2 cột "tô xanh trong file", vì dữ liệu vài ngàn dòng nên em làm thủ công không được chưa kể là dễ gây sai số. Liệu có cách nào tách đồng thời cả 2 cột được không ạ? Ngoài ra đây là dữ liệu không chính thức nên anh có thể bôi vàng những chỗ nào cần thay đổi nếu áp dụng file khác được không anh?

 

[snow25]

Cám ơn anh đã giúp em
Do em mới vào công ty và được bàn giao dữ liệu yêu cầu tách dòng ở 2 cột "tô xanh trong file", vì dữ liệu vài ngàn dòng nên em làm thủ công không được chưa kể là dễ gây sai số. Liệu có cách nào tách đồng thời cả 2 cột được không ạ? Ngoài ra đây là dữ liệu không chính thức nên anh có thể bôi vàng những chỗ nào cần thay đổi nếu áp dụng file khác được không anh?

Dữ liệu của bạn muốn tách theo 2 cột nhưng mà trong dữ liệu của bạn rất linh tinh.Bạn kéo cho nó rộng đủ cột cần tách xem nó như thế nào nhé.

 

[nguyensatran]

Dữ liệu của bạn muốn tách theo 2 cột nhưng mà trong dữ liệu của bạn rất linh tinh.Bạn kéo cho nó rộng đủ cột cần tách xem nó như thế nào nhé.

Có phải ý anh là người trước không xuống dòng theo kiểu Wrap text (hay Alt + Enter)? vậy giờ em phải sửa lại từng dòng cho dữ liệu chuẩn rồi mới tính tiếp được ạ?

 

[snow25]

Có phải ý anh là người trước không xuống dòng theo kiểu Wrap text (hay Alt + Enter)? vậy giờ em phải sửa lại từng dòng cho dữ liệu chuẩn rồi mới tính tiếp được ạ?

Đúng rồi đó bạn.Phải chỉnh lại thì mới được.

 

[nguyensatran]

Đúng rồi đó bạn.Phải chỉnh lại thì mới được.

Em đã chỉnh lại rồi, anh xem giúp nhé

 

[snow25]

Em đã chỉnh lại rồi, anh xem giúp nhé

Bạn chạy code này.Nó trả về ở sheets ketqua

Sub tach()
    Dim arr, i As Long, lr As Long, T, kq, a As Long, R As Long, L As Long, T1, k As Integer, j As Integer, b As Integer
    With Sheets("Detail")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         arr = .Range("B5:LW" & lr).Value
         R = UBound(arr)
         L = UBound(arr, 2)
         If R * 10 > Rows.Count Then a = Rows.Count Else a = R * 10
         ReDim kq(1 To a, 1 To L)
         a = 0
    End With
        For i = 1 To R
            T = Split(Chr(10) & arr(i, 13), Chr(10))
            T1 = Split(Chr(10) & arr(i, 14), Chr(10))
            b = UBound(T1)
            For k = 1 To UBound(T)
                If Len(T(k)) > 0 Then
                   a = a + 1
                   For j = 1 To L
                       kq(a, j) = arr(i, j)
                   Next j
                        kq(a, 13) = T(k)
                    If b >= k Then kq(a, 14) = T1(k) Else kq(a, 14) = Empty
                End If
            Next k
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 4 Then .Range("B5:O" & lr).ClearContents
         If a Then .Range("B5:o5").Resize(a).Value = kq
    End With
End Sub

 

[nguyensatran]

Bạn chạy code này.Nó trả về ở sheets ketqua

Sub tach()
    Dim arr, i As Long, lr As Long, T, kq, a As Long, R As Long, L As Long, T1, k As Integer, j As Integer, b As Integer
    With Sheets("Detail")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr = 1 Then Exit Sub
         arr = .Range("B5:LW" & lr).Value
         R = UBound(arr)
         L = UBound(arr, 2)
         If R * 10 > Rows.Count Then a = Rows.Count Else a = R * 10
         ReDim kq(1 To a, 1 To L)
         a = 0
    End With
        For i = 1 To R
            T = Split(Chr(10) & arr(i, 13), Chr(10))
            T1 = Split(Chr(10) & arr(i, 14), Chr(10))
            b = UBound(T1)
            For k = 1 To UBound(T)
                If Len(T(k)) > 0 Then
                   a = a + 1
                   For j = 1 To L
                       kq(a, j) = arr(i, j)
                   Next j
                        kq(a, 13) = T(k)
                    If b >= k Then kq(a, 14) = T1(k) Else kq(a, 14) = Empty
                End If
            Next k
       Next i
    With Sheets("ketqua")
         lr = .Range("B" & Rows.Count).End(xlUp).Row
         If lr > 4 Then .Range("B5:O" & lr).ClearContents
         If a Then .Range("B5:o5").Resize(a).Value = kq
    End With
End Sub

Em đã làm được rồi. Cảm ơn anh đã phản hồi thật nhanh. Chúc một ngày tốt lành