Tách các dữ liệu trong một ô thành nhiều dòng. (1 người xem)

[tranduyenit]

Xin chào cả nhà!
Tình hình là em có một file excel sau nhờ mọi người giúp đỡ.
Hiện em đang có nhiều dữ liệu chứa tại trong một ô được cách nhau bằng phím cách. Giờ em muốn nó được tách riêng các dữ liệu trong đó ra thành từng dòng trong 1 cột riêng biệt.
Cả nhà giúp em với. Em xin cảm ơn nhiều ạ.

 

[befaint]

.........................

 

[tranduyenit]

Cảm ơn bạn befaint nhiều nhé!!!

 

[tranduyenit]

Befaint và mợi người ơi!
Bây giờ tớ muốn nó xuất ra được như sau thì phải làm ntn? Giúp tớ với!

 

[befaint]

Befaint và mợi người ơi!
Bây giờ tớ muốn nó xuất ra được như sau thì phải làm ntn? Giúp tớ với!

Người ơi, người gửi luôn cái file đang làm đi cho rồi...

 

[tranduyenit]

Đó là cái file mà tớ đang làm đó.

 

[befaint]

Befaint và mợi người ơi!
Bây giờ tớ muốn nó xuất ra được như sau thì phải làm ntn? Giúp tớ với!

Sub TachTT()
Dim DL() As Variant, z As Long, r As Long, KQ() As Variant, j As Long
Dim chuoi As Variant, tmp As Variant, i As Long, PN As Variant, iPN As Long
With Sheet1
z = .Range("A" & .Rows.Count).End(xlUp).Row
DL = .Range("A4:B" & z): z = UBound(DL, 1)
ReDim KQ(1 To 65000, 1 To 2)
For r = 1 To z
    chuoi = DL(r, 2)
    If chuoi <> Empty Then
        chuoi = WorksheetFunction.Trim(chuoi)
        tmp = Split(chuoi, " ")
        For i = 0 To UBound(tmp)
            j = j + 1
            KQ(j, 1) = tmp(i)
            PN = Replace((DL(r, 1)), " ", "")
            If IsNumeric(Right(PN, 1)) = False Then iPN = 0 Else iPN = Right(PN, 1)
            KQ(j, 2) = Left(PN, Len(PN) - 1) & iPN + i
        Next i
        Erase tmp
    End If
Next r
If j Then
    .Range("C4").Resize(65000, 2).ClearContents
    .Range("C4").Resize(j, 2) = KQ
End If
End With
End Sub

 

[tranduyenit]

Tớ cảm ơn nhiều nhé.

 

[HieuCD]

Sub TachTT()
Dim DL() As Variant, z As Long, r As Long, KQ() As Variant, j As Long
Dim chuoi As Variant, tmp As Variant, i As Long, PN As Variant, iPN As Long
With Sheet1
z = .Range("A" & .Rows.Count).End(xlUp).Row
DL = .Range("A4:B" & z): z = UBound(DL, 1)
ReDim KQ(1 To 65000, 1 To 2)
For r = 1 To z
    chuoi = DL(r, 2)
    If chuoi <> Empty Then
        chuoi = WorksheetFunction.Trim(chuoi)
        tmp = Split(chuoi, " ")
        For i = 0 To UBound(tmp)
            j = j + 1
            KQ(j, 1) = tmp(i)
            PN = Replace((DL(r, 1)), " ", "")
            If IsNumeric(Right(PN, 1)) = False Then iPN = 0 Else iPN = Right(PN, 1)
            KQ(j, 2) = Left(PN, Len(PN) - 1) & iPN + i
        Next i
        Erase tmp
    End If
Next r
If j Then
    .Range("C4").Resize(65000, 2).ClearContents
    .Range("C4").Resize(j, 2) = KQ
End If
End With
End Sub

nếu ô A6 là 67308-1248 thì hơi mệt
chúc bạn một ngày vui

 

[befaint]

nếu ô A6 là 67308-1248 thì hơi mệt
chúc bạn một ngày vui

Kệ chứ anh

Chúc anh tối vui!

 

[Ba Tê]

Kệ chứ anh

Chúc anh tối vui!

Sao "Kệ" được ta?
67308-1248
67308-1249
67308-12410
67308-12411

Chạy "thí thí" cái này vậy. "Đúng Sai là sự thật"

Public Sub GPE()
Dim sArr(), dArr(1 To 1000, 1 To 2), i As Long, j As Long, Num As Long, K As Long, Txt As String, Tmp
sArr = Range("A4", Range("B4").End(xlDown)).Value
For i = 1 To UBound(sArr)
    K = K + 1: dArr(K, 2) = sArr(i, 1): dArr(K, 1) = Split(sArr(i, 2), " ")(0)
    sArr(i, 2) = Trim(sArr(i, 2))
    If InStr(sArr(i, 2), " ") Then
        Txt = Left(sArr(i, 1), InStr(sArr(i, 1), "-"))
        Num = Val(Mid(sArr(i, 1), InStr(sArr(i, 1), "-") + 1, 10))
        Tmp = Split(sArr(i, 2), " ")
        For j = 1 To UBound(Tmp)
            K = K + 1: Num = Num + 1
            dArr(K, 2) = Txt & Num
            dArr(K, 1) = Tmp(j)
        Next j
    End If
Next i
Range("F4").Resize(K, 2) = dArr
End Sub

 

[befaint]

Sao "Kệ" được ta?

Kệ được chứ anh. "kệ" để chờ xem dữ liệu đủ nhiều (hoặc toàn bộ) để xem xét.

Code của anh thử với:

B4=R53 R57 R68 R73

A6=67308-1242T