Tách thông tin thành 2 cột

[Phương Phương mito]

Kính gửi anh chị,
Em có nội dung tại cột A, mỗi ô gồm 2 dòng (xuống dòng bằng Alt+Enter). Code VBA làm sao để tách 2 dòng này ra cột B và C ạ. Em cảm ơn.

 

[snow25]

Kính gửi anh chị,
Em có nội dung tại cột A, mỗi ô gồm 2 dòng (xuống dòng bằng Alt+Enter). Code VBA làm sao để tách 2 dòng này ra cột B và C ạ. Em cảm ơn.

Thử code này.

Sub tach()
   Dim i As Long, lr As Long, arr, kq, T
   With Sheets("sheet1")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       arr = .Range("A2:B" & lr).Value
       ReDim kq(1 To UBound(arr), 1 To 2)
       For i = 1 To UBound(arr)
           T = Split(arr(i, 1), Chr(10))
           If UBound(T) > 0 Then
              kq(i, 1) = T(0)
              kq(i, 2) = T(1)
           End If
        Next i
        .Range("B2:C" & lr).Value = kq
    End With
End Sub

 

[befaint]

Sub chiaLy(byval rng as range)
Dim sDeli as string, data as variant, i as long, sText as string
Dim a as variant, res as variant
sDeli = vba.chr$(10)
data = rng.resize(rng.rows.count + 1).value2
redim res(1 to ubound(data,1)-1, 1 to 2)
for i=1 to ubound(data,1)-1
sText = data(i,1)
sText = vba.replace(sText, "'", "")
a = vba.split(sText, sDeli)
res(i,1)= vba.trim$(a(0))
if vba.instr(1, sText, sDeli)>0 then res(i,2) = vba.trim$(a(1))
next i
rng.cells(1,1).offset(0,1).resize(ubound(res,1), ubound(res,2)).value=res
erase data, res
end sub

 

[Phương Phương mito]

Thử code này.

Sub tach()
   Dim i As Long, lr As Long, arr, kq, T
   With Sheets("sheet1")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       arr = .Range("A2:B" & lr).Value
       ReDim kq(1 To UBound(arr), 1 To 2)
       For i = 1 To UBound(arr)
           T = Split(arr(i, 1), Chr(10))
           If UBound(T) > 0 Then
              kq(i, 1) = T(0)
              kq(i, 2) = T(1)
           End If
        Next i
        .Range("B2:C" & lr).Value = kq
    End With
End Sub

Code chạy đúng rồi, em cảm ơn anh nhiều ạ !

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

Sub chiaLy(byval rng as range)
Dim sDeli as string, data as variant, i as long, sText as string
Dim a as variant, res as variant
sDeli = vba.chr$(10)
data = rng.resize(rng.rows.count + 1).value2
redim res(1 to ubound(data,1)-1, 1 to 2)
for i=1 to ubound(data,1)-1
sText = data(i,1)
sText = vba.replace(sText, "'", "")
a = vba.split(sText, sDeli)
res(i,1)= vba.trim$(a(0))
if vba.instr(1, sText, sDeli)>0 then res(i,2) = vba.trim$(a(1))
next i
rng.cells(1,1).offset(0,1).resize(ubound(res,1), ubound(res,2)).value=res
erase data, res
end sub

Cảm ơn anh đã hỗ trợ em ạ !

 

[Phuocam]

Góp vui:

Sub TextToColumns()
Range("A2", Range("A" & Rows.Count).End(xlUp)).TextToColumns Destination:=Range("B2"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, Other:=True, OtherChar:=ChrW(10)
End Sub

 

[Cá ngừ F1]

Bạn thử hàm tự tạo này

Function TachTrai(Rng As String) As String
    TachTrai = Split(Rng, Chr(10))(0)
End Function
Function TachPhai(Rng As String) As String
    TachPhai = Split(Rng, Chr(10))(1)
End Function

Ô B2 dùng hàm tách trái (tách phía trái ký tự xuống dòng)
Ô C2 dùng hàm tách phải (tách phía bên phải ký tự xuống dòng)

Có thể kết hợp thêm Trim để bỏ dấu cách.

 

[befaint]

Cần bẫy lỗi trường hợp không có char(10) chứ.
Hoặc chí ít không có char(10) thì vẫn phải trả về kết quả chứ.

 

[Cá ngừ F1]

Cần bẫy lỗi trường hợp không có char(10) chứ.
Hoặc chí ít không có char(10) thì vẫn phải trả về kết quả chứ.

Món này là em học lỏm, cứ thấy ra kết quả là mừng lắm rồi (hay dùng để tách ký tự đặc biệt).
Mà Error nữa thì cứ Iferror mà xài thôi anh ạ.