Gõ công thức này vào cell D4:Chào các anh chị,
Tôi đang có 01 sheet excel nhưng không biết cách nào để tách dữ liệu được nhập trong 1 ô (dòng) ra thành nhiều dòng. Xin giúp đỡ và cám ơn rất nhiều.
=TRIM(MID(SUBSTITUTE($B$4,CHAR(10),REPT(" ",255)),(ROWS($1:1)-1)*255+1,255))
Tôi không hiểu bạn nói gì cả!Em cám ơn thầy, nhưng format nó không chạy theo hàng mà chạy dồn về bên phải. Không có cách làm cho nó bình thường được thầy ơi.
Tôi không hiểu bạn nói gì cả!
Có trục trặc gì cứ đưa file lên đây! Mô tả khó hiểu quá!
Bạn đưa dữ liệu khiêm tốn quá khố mà đạt được như ý bạnChào các anh chị,
Tôi đang có 01 sheet excel nhưng không biết cách nào để tách dữ liệu được nhập trong 1 ô (dòng) ra thành nhiều dòng. Xin giúp đỡ và cám ơn rất nhiều.
Bạn đưa dữ liệu khiêm tốn quá khố mà đạt được như ý bạn
Tốt nhất bạn đưa dữ liệu thật lên đi. Nếu dữ liệu như bạn nói rất có thể dùng VBA tốt hơnThật sự mình xin lỗi nhé, vì cũng không biết rằng nó dài dòng như vậy. Mình cần ra kết quả là một công thức kéo từ trên xuống dưới. Vì cột dữ liệu nguồn dài khoảng 1000 dòng nhưng khi đưa ví dụ mình chỉ đưa 3 dòng thôi. Nhờ anh giúp thêm nhé.
Tốt nhất bạn đưa dữ liệu thật lên đi. Nếu dữ liệu như bạn nói rất có thể dùng VBA tốt hơn
Bạn xem file thử nhé. Dùng VBA thôiDạ, em copy một đoạn dữ liệu nguồn của em. Mong anh giúp đỡ.
Em cám ơn anh nhiều nhé.Bạn xem file thử nhé. Dùng VBA thôi
Làm sao làm được như trong File này mà không cần VBA, tách dữ liệu từ 1 dòng ra nhiều dòng? rất mong được chỉ giáo, xin cảm ơn nhiều
=--TRIM(MID(SUBSTITUTE(D3,",",REPT(" ",LEN(D3))),(ROW(1:1)-1)*LEN(D3)+1,LEN(D3)))
Anh Vodoi2x ơi, công thức của anh mới tách chuỗi phân cách bởi dấu "," được một dòng thôi, nếu chỉ tách như anh thì anh PHI đã không hỏi vì mấy bài trên đã đề cập rồi. Anh PHI muốn tách hết dòng D3 thì tách tiếp dòng D4, D5 (nếu có)...Tách ký tự dấu phẩy thế này có nhiều rồi,
ví dụ tách chuỗi tại D3, có công thức
PHP:=--TRIM(MID(SUBSTITUTE(D3,",",REPT(" ",LEN(D3))),(ROW(1:1)-1)*LEN(D3)+1,LEN(D3)))
hay là có ý khác chăng???
Anh Vodoi2x ơi, công thức của anh mới tách chuỗi phân cách bởi dấu "," được một dòng thôi, nếu chỉ tách như anh thì anh PHI đã không hỏi vì mấy bài trên đã đề cập rồi. Anh PHI muốn tách hết dòng D3 thì tách tiếp dòng D4, D5 (nếu có)...
Ngày tháng của dòng được tách cũng phải đi kèm theo dữ liệu đc tách đó. He he!
cảm ơn 2 bạn nhiều, tôi muốn tách 1 (ô) dòng ra thành nhiều dòng cơ mà bài thì có rất nhiều ô để tách ,(bài giống như anh viet hoai) nhưng bây giờ không dùng VBA tôi muốn dùng công thức(có được không?)
vì tôi thấy bài của anh ndu tách 1 ô(dòng ) ra nhiều dòng rất hay nhưng chỉ tách được 1 ô thôi nên tôi muốn mở rộng thêm thôi. xin cảm ơn
Hình như tôi thấy đúng yêu cầu rồi đó, cảm ơn bạn nha để tôi có thời gian test thử xem còn sai chỗ nào không rồi chỉnh sửa tiếp.
Em nhờ các cao thủ tách giúp em file này. Dùng được VBA thì càng tốt. Nội dung:
Cần tách dữ liệu ở những ô cột C,D (Những ô cần tách em bôi vàng điển hình vài ô) trong sheet "Bang doc" các dữ liệu cách nhau bởi dấu "+"
Làm sao mà ta được đáp án như sheet "Bang doc 2"
Em xin chân thành cám ơn!
Sub abc()
Dim data(), Res(1 To 65536, 1 To 11), i, j, k, tam3, tam4
data = Sheet1.Range(Sheet1.[A7], Sheet1.[D65536].End(3).Offset(, 7)).Value
For i = 1 To UBound(data)
If data(i, 3) = "" Then
k = k + 1
For j = 1 To 11
Res(k, j) = data(i, j)
Next
Else
tam3 = Split(data(i, 3), "+")
tam4 = Split(data(i, 4), "+")
For ii = 1 To UBound(tam3) + 1
k = k + 1
For j = 1 To 11
Res(k, j) = data(i, j)
Next
Res(k, 3) = tam3(ii - 1)
Res(k, 4) = tam4(ii - 1)
Next
End If
Next
Sheet2.[A7].Resize(k, 11) = Res
End Sub
bạn thử làm theo cách sau:Dear các anh chị,
Em đang cần tách dữ liệu ô của cột A sang các cột B,C,D,E,F, G như file đính kèm. Em đã đọc bài hướng dẫn và lập theo công thức ở trên thì được kết quả như cột B. Cho em hỏi, em có thể làm như vậy cho các cột còn lại không và công thức như thế nào?
Vì em đang cần gấp nên mong mọi người giúp đỡ em.
Em cảm ơn nhiều lắm!
Thanks,
Vi
PHP:Sub abc() Dim data(), Res(1 To 65536, 1 To 11), i, j, k, tam3, tam4 data = Sheet1.Range(Sheet1.[A7], Sheet1.[D65536].End(3).Offset(, 7)).Value For i = 1 To UBound(data) If data(i, 3) = "" Then k = k + 1 For j = 1 To 11 Res(k, j) = data(i, j) Next Else tam3 = Split(data(i, 3), "+") tam4 = Split(data(i, 4), "+") For ii = 1 To UBound(tam3) + 1 k = k + 1 For j = 1 To 11 Res(k, j) = data(i, j) Next Res(k, 3) = tam3(ii - 1) Res(k, 4) = tam4(ii - 1) Next End If Next Sheet2.[A7].Resize(k, 11) = Res End Sub
Sub B_tachdong()Trường hợp mình muốn tách thêm cột E và cột G nữa thì viết code như thế nào hả anh?
E cám ơn anh nhiều!
Sub B_tachdong()
Dim data(), Res(1 To 65536, 1 To 11), i, j, k, g, f, tam3, tam4, tam5, tam7
data = Sheet1.Range(Sheet1.[A7], Sheet1.[G65536].End(3).Offset(, 7)).Value
For i = 1 To UBound(data)
If data(i, 3) = "" Then
k = k + 1
For j = 1 To 11
Res(k, j) = data(i, j)
Next
Else
tam3 = Split(data(i, 3), "+")
tam4 = Split(data(i, 4), "+")
tam5 = Split(data(i, 5), "+")
tam7 = Split(data(i, 7), "+")
For ii = 1 To UBound(tam3) + 1
k = k + 1
For j = 1 To 11
Res(k, j) = data(i, j)
Next
Res(k, 3) = tam3(ii - 1)
Res(k, 4) = tam4(ii - 1)
Res(k, 5) = tam4(ii - 1)
Res(k, 7) = tam7(ii - 1)
Next
End If
Next
Sheet3.[A7].Resize(k, 11) = Res
End Sub
Các anh kieemrtra giúp em code trên xem nó bị lỗi ở chỗ nào mà không chạy được vậy anh
Đoán là sai câu này:
data = Sheet1.Range(Sheet1.[A7], Sheet1.[G65536].End(3).Offset(, 7)).Value
Ai biết sửa thế nào vì chắc chắn là dữ liệu đã khác với cái file bạn gởi lên rồi đúng không?Code này bây giờ sửa thế nào vậy anh?
Em gửi File lên nhờ anh xem giúp.Ai biết sửa thế nào vì chắc chắn là dữ liệu đã khác với cái file bạn gởi lên rồi đúng không?
Ai biết sửa thế nào vì chắc chắn là dữ liệu đã khác với cái file bạn gởi lên rồi đúng không?
Vâng. Em gửi lại file để anh xem giúp nhé! Anh viết code tách giúp em thêm cột E và cột G nữa anh ạ!
Dear các anh chị,
Em dang can tach first name va last name cua file dinh kem thanh cac cot khac nhau. Em da thu tach bang cach tren nhung khong duoc. Moi nguoi giup em voi, khong hieu sao lan nay lai khong tach duoc nua.
Em dang can gap nen mong nhan duoc su giup do som tu cac anh chi trong dien dan.
Em cam on,
Vi
B2=SUBSTITUTE(A2,CHAR(160)," ")
ah, thì ra thế, sao tự dưng nghĩ thêm việc vào người vậy?
tức là muốn kết quả là A7:E18 từ dữ liệu A2:E5,
Vậy thì công thức sẽ phụ thuộc vào cột A, và khó là lập công thức cho cột A
Bạn xem file gửi kèm
Để chung một sheet vậy à hay cho sang sheet mới?Chào cả nhà.
Tôi xin nhờ cả nhà chỉ giúp cách tách 1 ô của 1 dòng thành nhiều dòng.
Cụ thể: Như file đính kèm
Nội dung này tôi rất cấn và tôi cũng đã mò mẫn mãi vẫn chưa có cách giải quyết.
Rất mong cả nhà hỗ trợ giúp tôi.
1 phútChào cả nhà.
Tôi xin nhờ cả nhà chỉ giúp cách tách 1 ô của 1 dòng thành nhiều dòng.
Cụ thể: Như file đính kèm
Nội dung này tôi rất cấn và tôi cũng đã mò mẫn mãi vẫn chưa có cách giải quyết.
Rất mong cả nhà hỗ trợ giúp tôi.
Cách này hay đó anh.
Topic đó bị khóa rồi mà. Mà tôi cũng có mô tả cách làm ở bài 2 rồiCách này hay đó anh.
Khai triển ở bài này à anh.
http://www.giaiphapexcel.com/diendan/threads/nhờ-gpe-giúp-tao-hàm-excel-tách-dữ-liệu-ra-nhiều-dòng-dựa-vào-cột-số-lượng.129115/
Thêm động tác chuyển cột số lượng =1 hết mất 2 giây nữa cho tròn 1phút.
-------
Trong video em thấy có nút "Xem mật khẩu wifi", tích hợp nhiều thứ ghê.![]()
Mấy cái linh tinh thôiTrong video em thấy có nút "Xem mật khẩu wifi", tích hợp nhiều thứ ghê.![]()
Bạn nên mở topic mới.Chào diễn đàn, nhờ mọi người giúp cho,
giúp mình đoạn code để làm như trong file mình gửi lên nhé :
tự xuống dòng khi gặp "(" hoặc "-"
Công thức của bạnChào các anh, chị!
Em đang có 01 sheet excel nhưng không biết cách nào để tách dữ liệu được nhập trong 1 dòng ra thành nhiều dòng. Xin giúp đỡ và cám ơn rất nhiều.
Em đã dùng những hàm ở trên nhưng chưa có kết quả.
Em cảm ơn.
="- "&TRIM(MID(SUBSTITUTE($E$5,";",REPT(" ",255)),(ROW(A1)-1)*255+1,255))
dữ liệu này nhiều lắm không? nếu nhiều thì nên sử dụng macroChào anh chị !
E là thành viên mới, anh chị giúp e tách file sau được không ạ?
E cảm ơn mọi người
nếu nhiều thì bạn nên cho thêm vài dòng dữ liệu nữa, chắc chắn với bạn là chưa tới 1h bạn sẽ có bài trả lời như ý muốnDạ nhiều anh ạ, e chỉ đưa ví dụ để miêu tả mong muốn của mình thôi ạ!e muốn nhờ anh chị giúp e bằng VBA ạ
E cảm ơn ạ
Bạn xem file.Dạ nhiều anh ạ, e chỉ đưa ví dụ để miêu tả mong muốn của mình thôi ạ!e muốn nhờ anh chị giúp e bằng VBA ạ
tách file
Sub vidu()
Const deli = ";"
Const maxR = 65000
Dim a, Res(), i, j, k, IDs, ID, maxC
a = Sheet2.UsedRange.Value
If IsArray(a) = False Then Exit Sub
maxC = UBound(a, 2)
ReDim Res(1 To maxR, 1 To maxC)
For k = 1 To maxC
Res(1, k) = a(1, k)
Next k
j = 1
For i = 2 To UBound(a, 1)
IDs = a(i, 1)
If Len(IDs) > 0 Then
For Each ID In Split(IDs, deli)
If j > maxR Then MsgBox "nhieu ket qua >> " & maxR: Exit Sub
j = j + 1
Res(j, 1) = ID
For k = 2 To maxC
Res(j, k) = a(i, k)
Next k
Next ID
End If
Next i
If j > 1 Then
Sheet1.UsedRange.ClearContents
Sheet1.Range("A1").Resize(j, maxC) = Res
End If
End Sub
Dạ được rồi ạ !!!! E cảm ơn anh nhiều ạBạn xem file.
Nếu cột A có 2 loại như thế này 601; 602 với cỡ 1000 dòng dữ liệu thì làm thủ công chắc cỡ 1 phút, chẳng cần code kiết gì cả.giúp mình tách hàng file này với! Không phải dân chuyên nên mấy lệnh dài dài không hiểu....
Xin cảm ơn!
giúp mình tách hàng file này với! Không phải dân chuyên nên mấy lệnh dài dài không hiểu....
Xin cảm ơn!
Tôi không hiểu bạn nói gì cả!
Có trục trặc gì cứ đưa file lên đây! Mô tả khó hiểu quá!
Anh ơi, nhờ anh gom hộ e hai sheet trong file trên vào 1 sheet được không ạ?ah, thì ra thế, sao tự dưng nghĩ thêm việc vào người vậy?
tức là muốn kết quả là A7:E18 từ dữ liệu A2:E5,
Vậy thì công thức sẽ phụ thuộc vào cột A, và khó là lập công thức cho cột A
Bạn xem file gửi kèm
Thử code này:Anh ơi, nhờ anh gom hộ e hai sheet trong file trên vào 1 sheet được không ạ?E cảm ơn anh nhiều
Option Explicit
Public Sub abc()
Dim tempArr As Variant, k As Long, i As Long, LastRow As Long
With Sheets("Source")
LastRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = LastRow To 2 Step -1
If InStr(.Range("A" & i).Value, ";") > 0 Then
tempArr = Split(.Range("A" & i).Value, ";")
k = UBound(tempArr)
.Rows(i).Offset(1).Resize(k).Insert
.Rows(i).Offset(1).Resize(k).Value = .Rows(i).Value
.Range("A" & i).Resize(k + 1).Value = Application.WorksheetFunction.Transpose(tempArr)
End If
Next i
End With
End Sub
1. Nếu có ai làm giúp bạn thì bạn cám ơn tiếp không?Em cảm ơn trước
Em đăng lên đây là muốn tìm cao nhân giúp vì kiến thức excel của e hạn hẹp, nhưng bác lại soi từng câu chữ thế này để làm gì nhỉ?1. Nếu có ai làm giúp bạn thì bạn cám ơn tiếp không?
2. Nếu không có ai làm giúp bạn thì bạn có rút lại không?
3. Hay như nào ngoài 1 và 2 ở trên?
Phải "soi" để đáp ứng yêu cầu của bạn chứ.Em đăng lên đây là muốn tìm cao nhân giúp vì kiến thức excel của e hạn hẹp, nhưng bác lại soi từng câu chữ thế này để làm gì nhỉ?
1. Nếu có ai làm giúp bạn thì bạn cám ơn tiếp không?
Nhờ bài soi đó mới biết bạn cũng không quan tâm đến câu trả lời. Anh em đỡ tốn công.Em đăng lên đây là muốn tìm cao nhân giúp vì kiến thức excel của e hạn hẹp, nhưng bác lại soi từng câu chữ thế này để làm gì nhỉ?
Hí hí, bạn bỏ mấy từ cao nhân gì gì đó đi. Nghe thấy ngại và nhột lắm.Em đăng lên đây là muốn tìm cao nhân giúp vì kiến thức excel của e hạn hẹp, nhưng bác lại soi từng câu chữ thế này để làm gì nhỉ?
Có nên thêm vào nội quy diễn đàn không nhỉ?Hí hí, bạn bỏ mấy từ cao nhân gì gì đó đi. Nghe thấy ngại và nhột lắm.
Sửa đi thì sẽ có kết quả ngay, còn không thì chờ ... 2019 !
Bạn chạy xem có đúng không nhé.Em chào các anh chị trong group.Em có 1 file sửa hàng mà bjo bên nhà cung cấp yêu cầu tách các lỗi ở cột H ra từng dòng riêng biệt,Anh chị có cách nào chỉ giúp em với ak.Em cảm ơn rất rất nhiều ak.
Sub tachloi()
Dim arr, arr1, lr As Long, i As Long, j As Long, a As Long, T
With Sheets("Detail (2)")
lr = .Range("H" & Rows.Count).End(xlUp).Row
If lr < 6 Then Exit Sub
arr = .Range("B6:K" & lr).Value
ReDim arr1(1 To UBound(arr, 1) * 4, 1 To UBound(arr, 2))
End With
For i = 1 To UBound(arr, 1)
For Each T In Split(arr(i, 7), ",")
a = a + 1
For j = 2 To UBound(arr, 2)
arr1(a, j) = arr(i, j)
Next j
arr1(a, 8) = T
arr1(a, 1) = a
Next
Next
With Sheets("ket qua")
lr = .Range("H" & Rows.Count).End(xlUp).Row
If lr > 5 Then .Range("B6:K" & lr).ClearContents
.Range("b6").Resize(a, UBound(arr, 2)).Value = arr1
End With
End Sub
Cho cái ví dụ xem nào bạn.Em muốn tách mỗi lỗi ở cột G thành từng dòng 1 những dữ liệu còn lại vẫn giữ nguyên ý ad ak??
Đây bạn xem.Ad check lại giúp em nhé
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.Nhờ các Anh/chị giúp em tách từ 1 dòng thành nhiều dòng như file đính kèm với ạ. Bài của em hoàn toàn khác với vấn đề mà mọi người đã giải đáp ở trên nên em không áp dụng được. Nếu có thể giúp em tách theo 2 cách em đã làm thủ công ở 2 sheet kế bên.
Xin cám ơn nhiều
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
Em đã sửa file chắc do lúc em tải lên chưa lưu lại.Code bài đăng có mà.Trong File của bạn thiếu Next k
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.
Mã: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
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á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é.
Đúng rồi đó bạn.Phải chỉnh lại thì mới được.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 ạ?
Em đã chỉnh lại rồi, anh xem giúp nhéĐúng rồi đó bạn.Phải chỉnh lại thì mới được.
Bạn chạy code này.Nó trả về ở sheets ketquaEm đã chỉnh lại rồi, anh xem giúp nhé
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ànhBạn chạy code này.Nó trả về ở sheets ketqua
Mã: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