Phân tích dữ liệu chuỗi thành 4 cột riêng biệt - Anh chị giúp đỡ

[htgiangdt]

Chào anh chị, em nhờ anh chị giúp em đề bài sau:
Phân tích chuỗi "Cột gốc" chia vào 4 cột B,C,D,E.
Em có danh mục của 4 cột B,C,D,E

Cám ơn anh chị
Email: giang.ht3@gmail.com

Ví dụ:

Cột gốc	Năm ban hành	Cơ quan ban hành	Lĩnh vực	Loại văn bản
nam-ban-hanh~2013:2013,co-quan-ban-hanh~bo-ke-hoach-va-dau-tu:Bộ Kế hoạch và Đầu tư,co-quan-ban-hanh~bo-tai-chinh:Bộ Tài chính,co-quan-ban-hanh~bo-tai-nguyen-va-moi-truong:Bộ Tài nguyên và Môi trường,linh-vuc~tai-chinh:Tài chính,linh-vuc~tai-nguyen-va-moi-truong:Tài nguyên và Môi trường,loai-van-ban~thong-tu-lien-tich:Thông tư liên tịch	2013	Bộ Kế hoạch và đầu tư Bộ Tài chính Bộ Tài nguyên và Môi trường	Tài chính Tài nguyên và môi trường	Thông tư liên tịch
co-quan-ban-hanh~bo-giao-duc-va-dao-tao:Bộ Giáo dục và Đào tạo,co-quan-ban-hanh~bo-tai-chinh:Bộ Tài chính,linh-vuc~giao-duc-va-dao-tao:Giáo dục và đào tạo,loai-van-ban~thong-tu-lien-tich:Thông tư liên tịch	?	?	?	?
nam-ban-hanh~2015:2015,co-quan-ban-hanh~bo-lao-dong-thuong-binh-va-xa-hoi:Bộ Lao động - Thương binh và Xã hội,linh-vuc~lao-dong-thuong-binh-xa-hoi:Lao động- Thương binh- Xã hội,linh-vuc~tai-chinh:Tài chính,loai-van-ban~thong-tu:Thông tư	?	?	?	?

 

[gtri]

Chào anh chị, em nhờ anh chị giúp em đề bài sau:
Phân tích chuỗi "Cột gốc" chia vào 4 cột B,C,D,E.
Em có danh mục của 4 cột B,C,D,E

Cám ơn anh chị
Email: giang.ht3@gmail.com

Ví dụ:

Cột gốc	Năm ban hành	Cơ quan ban hành	Lĩnh vực	Loại văn bản
nam-ban-hanh~2013:2013,co-quan-ban-hanh~bo-ke-hoach-va-dau-tu:Bộ Kế hoạch và Đầu tư,co-quan-ban-hanh~bo-tai-chinh:Bộ Tài chính,co-quan-ban-hanh~bo-tai-nguyen-va-moi-truong:Bộ Tài nguyên và Môi trường,linh-vuc~tai-chinh:Tài chính,linh-vuc~tai-nguyen-va-moi-truong:Tài nguyên và Môi trường,loai-van-ban~thong-tu-lien-tich:Thông tư liên tịch	2013	Bộ Kế hoạch và đầu tư Bộ Tài chính Bộ Tài nguyên và Môi trường	Tài chính Tài nguyên và môi trường	Thông tư liên tịch
co-quan-ban-hanh~bo-giao-duc-va-dao-tao:Bộ Giáo dục và Đào tạo,co-quan-ban-hanh~bo-tai-chinh:Bộ Tài chính,linh-vuc~giao-duc-va-dao-tao:Giáo dục và đào tạo,loai-van-ban~thong-tu-lien-tich:Thông tư liên tịch	?	?	?	?
nam-ban-hanh~2015:2015,co-quan-ban-hanh~bo-lao-dong-thuong-binh-va-xa-hoi:Bộ Lao động - Thương binh và Xã hội,linh-vuc~lao-dong-thuong-binh-xa-hoi:Lao động- Thương binh- Xã hội,linh-vuc~tai-chinh:Tài chính,loai-van-ban~thong-tu:Thông tư	?	?	?	?

Dùng thử đoạn code này xem sao

Public Sub Tach_Chuoi()
Dim DL, kq(), Tam, r As Long, c As Long

DL = Sheet1.Range("A5:A7")
ReDim kq(1 To UBound(DL), 1 To 4)

For r = 1 To UBound(DL)
Tam = Split(DL(r, 1), ",")
For c = 0 To UBound(Tam)
If InStr(1, Tam(c), "nam-ban-hanh", 1) Then
kq(r, 1) = kq(r, 1) & Chr(10) & Split(Tam(c), ":")(1)
Else
If InStr(1, Tam(c), "co-quan-ban-hanh", 1) Then
kq(r, 2) = kq(r, 2) & Chr(10) & Split(Tam(c), ":")(1)
Else
If InStr(1, Tam(c), "linh-vuc", 1) Then
kq(r, 3) = kq(r, 3) & Chr(10) & Split(Tam(c), ":")(1)
Else
kq(r, 4) = kq(r, 4) & Chr(10) & Split(Tam(c), ":")(1)
End If
End If
End If
Next c
Next r

Sheet1.Range("G5").Resize(UBound(kq), 4).Value = kq
Sheet1.Range("G5").CurrentRegion.WrapText = True

End Sub

 

[VetMini]

Cái này dùng RegEx rất hữu hiệu.
Bạn nào muốn thử dợt nghề thì đây là cơ hội tốt.

 

[VetMini]

Chả ai hưởng ứng cả?
Thử trước xem ai có kiểu nào hay hơn hôn.

Function TimDuLieu(ByVal s As String, ByVal cde As String, Optional dlm As String = ",") As String
[COLOR=#008000]' hàm lấy chuỗi dữ liệu ứng theo loại trong một chuỗi khác
[/COLOR]Dim matches As Variant, match As Variant
Static rx As Object [COLOR=#008000]' tránh tạo object nhiều lần nếu hàm được gọi đi gọi lại nhiều lần[/COLOR]
If rx Is Nothing Then
Set rx = CreateObject("VBScript.RegExp")
rx.Global = True
rx.Ignorecase = True
End If
TimDuLieu = ""
[COLOR=#008000]' phải dùng capture và submatch vì VBScirpt RegEx không có chuyện lookbehind - đáng tiếc!
[/COLOR]rx.Pattern = cde & "~[^,]+:([^,]+)"
If rx.test(s) Then
    Set matches = rx.Execute(s)
    For Each match In matches
    TimDuLieu = TimDuLieu & IIf(Len(TimDuLieu) > 0, dlm, "") & match.submatches(0)
    Next match
End If
End Function

Sub t()
[COLOR=#008000]' sub dùng để test hàm trên
' nếu dùng thì chỉnh code lấy số hàng trong cột A
[/COLOR]Dim c
For Each c In [a2:a6]
c.Offset(, 1) = TimDuLieu(c, "nam-ban-hanh", Chr(10))
c.Offset(, 2) = TimDuLieu(c, "co-quan-ban-hanh", Chr(10))
c.Offset(, 3) = TimDuLieu(c, "linh-vuc", Chr(10))
c.Offset(, 4) = TimDuLieu(c, "loai-van-ban", Chr(10))
Next c
End Sub

 

[gtri]

Chả ai hưởng ứng cả?
Thử trước xem ai có kiểu nào hay hơn hôn.

Function TimDuLieu(ByVal s As String, ByVal cde As String, Optional dlm As String = ",") As String
[COLOR=#008000]' hàm lấy chuỗi dữ liệu ứng theo loại trong một chuỗi khác
[/COLOR]Dim matches As Variant, match As Variant
Static rx As Object [COLOR=#008000]' tránh tạo object nhiều lần nếu hàm được gọi đi gọi lại nhiều lần[/COLOR]
If rx Is Nothing Then
Set rx = CreateObject("VBScript.RegExp")
rx.Global = True
rx.Ignorecase = True
End If
TimDuLieu = ""
[COLOR=#008000]' phải dùng capture và submatch vì VBScirpt RegEx không có chuyện lookbehind - đáng tiếc!
[/COLOR]rx.Pattern = cde & "~[^,]+:([^,]+)"
If rx.test(s) Then
    Set matches = rx.Execute(s)
    For Each match In matches
    TimDuLieu = TimDuLieu & IIf(Len(TimDuLieu) > 0, dlm, "") & match.submatches(0)
    Next match
End If
End Function

Sub t()
[COLOR=#008000]' sub dùng để test hàm trên
' nếu dùng thì chỉnh code lấy số hàng trong cột A
[/COLOR]Dim c
For Each c In [a2:a6]
c.Offset(, 1) = TimDuLieu(c, "nam-ban-hanh", Chr(10))
c.Offset(, 2) = TimDuLieu(c, "co-quan-ban-hanh", Chr(10))
c.Offset(, 3) = TimDuLieu(c, "linh-vuc", Chr(10))
c.Offset(, 4) = TimDuLieu(c, "loai-van-ban", Chr(10))
Next c
End Sub

Bó tay, quả là tìm không ra cách gọn hơn.
Thank!

 

[htgiangdt]

Cám ơn anh/chị VetMini và gtri đã giải đáp cho em ^^ Em đang dùng thử.
Chúc hai anh/chị vui khỏe

 

[Ba Tê]

Chả ai hưởng ứng cả?
Thử trước xem ai có kiểu nào hay hơn hôn.

Function TimDuLieu(ByVal s As String, ByVal cde As String, Optional dlm As String = ",") As String
[COLOR=#008000]' hàm lấy chuỗi dữ liệu ứng theo loại trong một chuỗi khác
[/COLOR]Dim matches As Variant, match As Variant
Static rx As Object [COLOR=#008000]' tránh tạo object nhiều lần nếu hàm được gọi đi gọi lại nhiều lần[/COLOR]
If rx Is Nothing Then
Set rx = CreateObject("VBScript.RegExp")
rx.Global = True
rx.Ignorecase = True
End If
TimDuLieu = ""
[COLOR=#008000]' phải dùng capture và submatch vì VBScirpt RegEx không có chuyện lookbehind - đáng tiếc!
[/COLOR]rx.Pattern = cde & "~[^,]+:([^,]+)"
If rx.test(s) Then
    Set matches = rx.Execute(s)
    For Each match In matches
    TimDuLieu = TimDuLieu & IIf(Len(TimDuLieu) > 0, dlm, "") & match.submatches(0)
    Next match
End If
End Function

Sub t()
[COLOR=#008000]' sub dùng để test hàm trên
' nếu dùng thì chỉnh code lấy số hàng trong cột A
[/COLOR]Dim c
For Each c In [a2:a6]
c.Offset(, 1) = TimDuLieu(c, "nam-ban-hanh", Chr(10))
c.Offset(, 2) = TimDuLieu(c, "co-quan-ban-hanh", Chr(10))
c.Offset(, 3) = TimDuLieu(c, "linh-vuc", Chr(10))
c.Offset(, 4) = TimDuLieu(c, "loai-van-ban", Chr(10))
Next c
End Sub

Hưởng ứng 1 Function, có tiêu đề phụ.

Public Function GPE(Rng As Range, DK As Range) As String
Dim Tem, J As Long
Tem = Split(Rng, ",")
For J = 0 To UBound(Tem)
    If Tem(J) Like DK & "*" Then
        GPE = GPE & Mid(Tem(J), InStr(Tem(J), ":") + 1, 1000) & ", "
    End If
Next J
If Len(GPE) Then GPE = Left(GPE, Len(GPE) - 2)
End Function