So sánh và tách chuỗi khác nhau trong excel

[giauvn]

Xin chào các bạn mình đang xử lý dữ liệu này hơi rối não xíu.
Mình có 200 dòng dữ liệu gần giống với file kèm theo. File kèm theo ví dụ về 19 dòng dữ liệu.
Mỗi dòng dữ liệu có thể lên đến 2000 số. Mỗi chuỗi số trong đó gồm các bộ 4 số tính từ số thứ nhất đến số thứ tư là một mã sản phẩm ( Ví dụ dòng đầu tiên là 262512227715152625...... thì 2625 là 1 mã SP, 1222, 7715 là mỗi mã SP)
Mình muốn lấy một chuỗi dài nhất trong 200 dòng đó làm chuỗi chính trả ra giá trị trong ô C2.
Lấy 199 chuỗi còn lại lần lượt só sánh với chuỗi chính nếu khi các bộ mã SP liên tiếp nhau có sự khác nhau với chuỗi chính thì cắt chuỗi từ vị trí đó (mỗi mã SP là 1 bộ 4 số). Sau đó lấy 1 trong 199 chuỗi cắt ra đó chuỗi nào dài nhất thì lấy làm chuỗi chính rồi lấy 198 chuỗi còn lại so sanh tương tự như thế đến khi nào hết sự giống nhau.
Cuối cùng lấy các chuỗi khác nhau đó trả về các ô C3, C4, C5...... theo thứ tự từ dài đến ngắn.

Cảm ơn các bạn quan tâm

 

[excel_lv1.5]

Xin chào các bạn mình đang xử lý dữ liệu này hơi rối não xíu.
Mình có 200 dòng dữ liệu gần giống với file kèm theo. File kèm theo ví dụ về 19 dòng dữ liệu.
Mỗi dòng dữ liệu có thể lên đến 2000 số. Mỗi chuỗi số trong đó gồm các bộ 4 số tính từ số thứ nhất đến số thứ tư là một mã sản phẩm ( Ví dụ dòng đầu tiên là 262512227715152625...... thì 2625 là 1 mã SP, 1222, 7715 là mỗi mã SP)
Mình muốn lấy một chuỗi dài nhất trong 200 dòng đó làm chuỗi chính trả ra giá trị trong ô C2.
Lấy 199 chuỗi còn lại lần lượt só sánh với chuỗi chính nếu khi các bộ mã SP liên tiếp nhau có sự khác nhau với chuỗi chính thì cắt chuỗi từ vị trí đó (mỗi mã SP là 1 bộ 4 số). Sau đó lấy 1 trong 199 chuỗi cắt ra đó chuỗi nào dài nhất thì lấy làm chuỗi chính rồi lấy 198 chuỗi còn lại so sanh tương tự như thế đến khi nào hết sự giống nhau.
Cuối cùng lấy các chuỗi khác nhau đó trả về các ô C3, C4, C5...... theo thứ tự từ dài đến ngắn.

Cảm ơn các bạn quan tâm

Bạn chạy code này, kết quả trả về bên sheet2 cho dễ nhìn:

Option Explicit
Option Base 1
Public Sub b()
Dim arr(), arrres(), i As Long, arrstr(), arrres2, n As Long
arr = Application.Transpose(Sheets("sheet1").Range("b2:b" & Sheets("sheet1").[b10000].End(xlUp).Row))
arrstr = arr
ReDim arrres2(1 To UBound(arr) + 1, 1)
Do While UBound(arrstr) > 1
    arrres() = findd(arrstr)
    n = n + 1: arrres2(n, 1) = arrres(2)
    ReDim arrstr(1 To UBound(arrres(1)) + 1)
    For i = 0 To UBound(arrres(1))
        arrstr(i + 1) = checkstr(arrres(2), arrres(1)(i))
    Next
Loop
arrres2(n + 1, 1) = arrstr(1)
Sheets("Sheet2").[a1].Resize(UBound(arrres2), 1) = arrres2
End Sub
Private Function checkstr(ByVal str As String, ByVal str2 As String) As String
Dim i As Long: i = 1
Do While Mid(str, 1, 4 * i) = Mid(str2, 1, 4 * i)
    i = i + 1
Loop
checkstr = Mid(str2, 4 * (i - 1) + 1, 4000)
End Function
Private Function findd(ByVal arr)
Dim dic As Object, wf As WorksheetFunction, strm As String, i As Long
Set dic = CreateObject("scripting.dictionary")
Set wf = WorksheetFunction
With dic
For i = 1 To UBound(arr)
    If Not .exists(arr(i)) Then
        .Add arr(i), Len(arr(i))
    End If
Next
strm = .keys()(wf.Match(wf.Max(.items()), .items(), 0) - 1)
End With
dic.Remove strm: findd = Array(dic.keys(), strm)

 

[CHAOQUAY]

...Mình muốn lấy một chuỗi dài nhất trong 200 dòng đó làm chuỗi chính trả ra giá trị trong ô C2.
Lấy 199 chuỗi còn lại lần lượt só sánh với chuỗi chính nếu khi các bộ mã SP liên tiếp nhau có sự khác nhau với chuỗi chính thì cắt chuỗi từ vị trí đó (mỗi mã SP là 1 bộ 4 số). Sau đó lấy 1 trong 199 chuỗi cắt ra đó chuỗi nào dài nhất thì lấy làm chuỗi chính rồi lấy 198 chuỗi còn lại so sanh tương tự như thế đến khi nào hết sự giống nhau.
Cuối cùng lấy các chuỗi khác nhau đó trả về các ô C3, C4, C5...... theo thứ tự từ dài đến ngắn.

Cảm ơn các bạn quan tâm

Với chuỗi đang xét
Chỗ màu đỏ:
Các bộ mã liên tiếp này bắt đầu từ đâu: điểm bất kỳ hay là từ đầu chuỗi?
Chỗ màu xanh:
Cắt xong lấy phần nào?

 

[giauvn]

Với chuỗi đang xét
Chỗ màu đỏ:
Các bộ mã liên tiếp này bắt đầu từ đâu: điểm bất kỳ hay là từ đầu chuỗi?
Chỗ màu xanh:
Cắt xong lấy phần nào?

Chổ màu đỏ : Các bộ mã này tính từ đầu chuỗi bạn nhé. Ví dụ chuỗi này 26251222774720421927 thì bộ mã của mình lần lượt là 2625, 1222,7747,202,1927. bộ thứ nhất tính từ kí tự thứ nhất (4x0+1) và lấy ra liên tiếp 4 kí tự kí tự sau đó, bộ thứ 2 được tính từ kí tự thứ 5 (4x1+1) và lấy ra liên tiếp 4 kí tự kí tự sau đó, bộ thứ 3 lấy từ kí tự thứ 9(4x2+1) lấy ra liên tiếp 4 kí tự kí tự sau đó, bộ thứ tư lấy từ kí tự thứ 13(4x3+1) lấy ra liên tiếp 4 kí tự sau đó......
Chổ màu xanh : Mình muốn lấy từ vị trí khác nhau đó đến cuối chuỗi.

Cảm ơn bạn đã quan tâm

 

[CHAOQUAY]

@giauvn Tham khảo thêm 1 cách

Option Explicit

Sub abcd()
Dim SArr, Arr0, Arr1, Res
Dim rws, i, j, k, x, z, t
SArr = Sheet1.Range("B2", Sheet1.Range("B2").End(xlDown))
rws = UBound(SArr)
ReDim Res(1 To rws, 1 To 1)
For j = 1 To rws
    If i < Len(SArr(j, 1)) Then
        i = Len(SArr(j, 1))
        t = j
    End If
Next j
Res(1, 1) = SArr(t, 1)
SArr(t, 1) = SArr(rws, 1)
With CreateObject("VbScript.RegExp")
    .Pattern = "\d"
    .Global = True
    x = 1
    Do While x < rws
        t = 0
        Set Arr0 = .Execute(Res(x, 1))
        For j = 1 To rws - x
            Set Arr1 = .Execute(SArr(j, 1))
            For i = 0 To Arr1.Count - 1
                If Arr1(i) <> Arr0(i) Then
                    k = Arr1.Count - ((i + 1) \ 4) * 4
                    SArr(j, 1) = Right(SArr(j, 1), k)
                    If t < k Then
                        t = k
                        z = j
                    End If
                    Exit For
                End If
            Next i
        Next j
        x = x + 1
        Res(x, 1) = SArr(z, 1)
        SArr(z, 1) = SArr(rws - x + 1, 1)
    Loop
End With
With Sheet2
    .UsedRange.Clear
    .Range("A1:A" & rws).NumberFormat = "@"
    .Range("A1:A" & rws) = Res
End With
End Sub

 

[giauvn]

Bạn chạy code này, kết quả trả về bên sheet2 cho dễ nhìn:

Option Explicit
Option Base 1
Public Sub b()
Dim arr(), arrres(), i As Long, arrstr(), arrres2, n As Long
arr = Application.Transpose(Sheets("sheet1").Range("b2:b" & Sheets("sheet1").[b10000].End(xlUp).Row))
arrstr = arr
ReDim arrres2(1 To UBound(arr) + 1, 1)
Do While UBound(arrstr) > 1
    arrres() = findd(arrstr)
    n = n + 1: arrres2(n, 1) = arrres(2)
    ReDim arrstr(1 To UBound(arrres(1)) + 1)
    For i = 0 To UBound(arrres(1))
        arrstr(i + 1) = checkstr(arrres(2), arrres(1)(i))
    Next
Loop
arrres2(n + 1, 1) = arrstr(1)
Sheets("Sheet2").[a1].Resize(UBound(arrres2), 1) = arrres2
End Sub
Private Function checkstr(ByVal str As String, ByVal str2 As String) As String
Dim i As Long: i = 1
Do While Mid(str, 1, 4 * i) = Mid(str2, 1, 4 * i)
    i = i + 1
Loop
checkstr = Mid(str2, 4 * (i - 1) + 1, 4000)
End Function
Private Function findd(ByVal arr)
Dim dic As Object, wf As WorksheetFunction, strm As String, i As Long
Set dic = CreateObject("scripting.dictionary")
Set wf = WorksheetFunction
With dic
For i = 1 To UBound(arr)
    If Not .exists(arr(i)) Then
        .Add arr(i), Len(arr(i))
    End If
Next
strm = .keys()(wf.Match(wf.Max(.items()), .items(), 0) - 1)
End With
dic.Remove strm: findd = Array(dic.keys(), strm)

Code của bạn khá tốt.
Mình xin thêm cột B trong Sheet 2 chỉ ra được vị trí khác nhau đó luôn hoặc lấy Vị trí khác đó Nối chuỗi với chuỗi trả về giá trị đó (vị trí đó được tính từ đầu chuỗi mỗi bộ 4 số liên tiếp là tính 1 vị trí nhé).
Cảm ơn nhưng dòng code của bạn. Mình ứng dụng 2 đoạn code trên rất tuyệt vời.

 

[excel_lv1.5]

Code của bạn khá tốt.
Mình xin thêm cột B trong Sheet 2 chỉ ra được vị trí khác nhau đó luôn hoặc lấy Vị trí khác đó Nối chuỗi với chuỗi trả về giá trị đó (vị trí đó được tính từ đầu chuỗi mỗi bộ 4 số liên tiếp là tính 1 vị trí nhé).
Cảm ơn nhưng dòng code của bạn. Mình ứng dụng 2 đoạn code trên rất tuyệt vời.

Tôi chưa hiểu ý bạn?