Tìm quy luật tách chuỗi dữ liệu

[huonglien1901]

Mình thử thấy bài #6 có ra kết quả mà, vẫn chưa đúng ý à

Uhm. Đúng ý rồi à. Ý là em trả lời code #8. Em thấy code gần trọn vẹn rồi. Em thấy có trường hợp trước số mà không có dấu nháy đơn thì nó không tách được.

 

[huonglien1901]

Sửa đoạn pattern
"([\n':-] +(\d{4,30}))|((\d{4,30}) ?[,_-])"

Code của Anh ban đầu tách gần hết rồi đó Anh. Trường hợp trước những chuỗi số không có dấu nháy ' thì nó chưa tách được thôi.

 

[HieuCD]

Chào mọi người!

Em có vấn đề nhờ mọi người hỗ trợ.

Em muốn nhờ mọi người tìm quy luật tách chuỗi này.
Em cần lấy những con số trong file đính kèm mà em.vẫn chưa tìm ra được quy luật.
Em vẫn chưa tìm được quy luật tách chuỗi. Mọi người xem có thể xem và hỗ trợ em vấn đề này không?
Em cảm ơn mọi người nhiều!

Chạy code

Sub ABC()
  Dim sArr(), Res() As String, iChar$
  Dim i&, N&, j&, j2&, k&, jC&
 
  sArr = Range("A5", Range("A" & Rows.Count).End(xlUp)).Value
  srow = UBound(sArr)
  ReDim Res(1 To srow, 1 To 10)
  For i = 1 To srow
    tmp = sArr(i, 1)
    N = Len(tmp)
    jC = 0
    For j = 1 To N - 6
      If IsNumeric(Mid(tmp, j, 1)) Then
        k = 1
        For j2 = j + 1 To N
          iChar = Mid(tmp, j2, 1)
          If IsNumeric(iChar) Or iChar = " " Then
            k = k + 1
          Else
            j2 = j2 + 1: Exit For
          End If
        Next j2
        If k > 5 Then
          jC = jC + 1
          Res(i, jC) = Trim(Mid(tmp, j, k))
        End If
        j = j2 - 1
      End If
    Next j
  Next i
  Range("B5").Resize(srow, 10) = Res
End Sub

 

[huonglien1901]

Chạy code

Sub ABC()
  Dim sArr(), Res() As String, iChar$
  Dim i&, N&, j&, j2&, k&, jC&

  sArr = Range("A5", Range("A" & Rows.Count).End(xlUp)).Value
  srow = UBound(sArr)
  ReDim Res(1 To srow, 1 To 10)
  For i = 1 To srow
    tmp = sArr(i, 1)
    N = Len(tmp)
    jC = 0
    For j = 1 To N - 6
      If IsNumeric(Mid(tmp, j, 1)) Then
        k = 1
        For j2 = j + 1 To N
          iChar = Mid(tmp, j2, 1)
          If IsNumeric(iChar) Or iChar = " " Then
            k = k + 1
          Else
            j2 = j2 + 1: Exit For
          End If
        Next j2
        If k > 5 Then
          jC = jC + 1
          Res(i, jC) = Trim(Mid(tmp, j, k))
        End If
        j = j2 - 1
      End If
    Next j
  Next i
  Range("B5").Resize(srow, 10) = Res
End Sub

Cảm ơn Anh nhiều! Có gì em test rồi phản hồi lại cho Anh.

 

[dazkangel]

Công thức vui :v

=IFERROR(MID(AGGREGATE(14,6,--(1&MID(SUBSTITUTE($A5," ","")&"''",ROW(INDIRECT("1:"&LEN($A5))),{6,8,13})),COLUMN(A:A)),2,13),"")

 

[huonglien1901]

Công thức vui :v

=IFERROR(MID(AGGREGATE(14,6,--(1&MID(SUBSTITUTE($A5," ","")&"''",ROW(INDIRECT("1:"&LEN($A5))),{6,8,13})),COLUMN(A:A)),2,13),"")

Không ngờ bài toán này có thể dùng công thức được luôn.

 

[dazkangel]

Không ngờ bài toán này có thể dùng công thức được luôn.

Anh nghĩ có thể thêm 1 điều kiện nếu len của ô hiện tại không bằng ô trước thì bỏ qua là hoàn thành ) nhưng dài quá nên không đưa lên

 

[huonglien1901]

Anh nghĩ có thể thêm 1 điều kiện nếu len của ô hiện tại không bằng ô trước thì bỏ qua là hoàn thành ) nhưng dài quá nên không đưa lên

Anh có thể đưa lên cho mọi người tham khảo đó Anh.

 

[dazkangel]

Anh có thể đưa lên cho mọi người tham khảo đó Anh.

Em làm được mà, dùng conditional formatting nếu len ô hiện tại nhỏ hơn len ô kế bên thì tắt đi .
Lười mang lên lắm nhìn chả ra sao

 

[phuongvq123]

Anh nghĩ có thể thêm 1 điều kiện nếu len của ô hiện tại không bằng ô trước thì bỏ qua là hoàn thành ) nhưng dài quá nên không đưa lên

Mình thử công thức trên mà chưa ra

 

[dazkangel]

Mình thử công thức trên mà chưa ra

Xem file và conditional formatting.

 

[dazkangel]

Anh có thể đưa lên cho mọi người tham khảo đó Anh.

Công thức cuối cùng khỏi xài conditional formatting.

=IFERROR(MID(TEXT(AGGREGATE(14,6,--(1&MID(SUBSTITUTE($A5," ","")&"'",ROW(INDIRECT("1:"&LEN($A5))),{6,8,13})),COLUMN(A:A)),"[>"&REPT(9,TEXT(LEN(A5),"[=0]13;[>13]1;0"))&"]#;"),2,13),"")

 

[HeSanbi]

Code của Anh ban đầu tách gần hết rồi đó Anh. Trường hợp trước những chuỗi số không có dấu nháy ' thì nó chưa tách được thôi.

Nếu bạn muốn tách 6 số trở lên thì thay thế hàm scraper sau cho hàm scraper ở code trên

Private Function scraper(ByVal text$, Optional ByRef re As Object)
  scraper = Array("")
  If re Is Nothing Then
    Set re = VBA.CreateObject("VBScript.RegExp")
    With re
      .Global = True
      .IgnoreCase = True
      .MultiLine = True
      .pattern = "\d{6,30}"
    End With
  End If
  Dim m, ms, t$, i%, k%, Arr()
  Set ms = re.Execute(text)
  If ms.Count Then
    ReDim Arr(ms.Count - 1)
    For i = 0 To ms.Count - 1
      Arr(i) = ms(i)
    Next
    scraper = Arr
  End If
End Function

 

[huonglien1901]

Nếu bạn muốn tách 6 số trở lên thì thay thế hàm scraper sau cho hàm scraper ở code trên

Private Function scraper(ByVal text$, Optional ByRef re As Object)
  scraper = Array("")
  If re Is Nothing Then
    Set re = VBA.CreateObject("VBScript.RegExp")
    With re
      .Global = True
      .IgnoreCase = True
      .MultiLine = True
      .pattern = "\d{6,30}"
    End With
  End If
  Dim m, ms, t$, i%, k%, Arr()
  Set ms = re.Execute(text)
  If ms.Count Then
    ReDim Arr(ms.Count - 1)
    For i = 0 To ms.Count - 1
      Arr(i) = ms(i)
    Next
    scraper = Arr
  End If
End Function

Trường hợp chuỗi số không có dấu nháy đơn đầu có tách được không Anh.

 

[huonglien1901]

Nếu bạn muốn tách 6 số trở lên thì thay thế hàm scraper sau cho hàm scraper ở code trên

Private Function scraper(ByVal text$, Optional ByRef re As Object)
  scraper = Array("")
  If re Is Nothing Then
    Set re = VBA.CreateObject("VBScript.RegExp")
    With re
      .Global = True
      .IgnoreCase = True
      .MultiLine = True
      .pattern = "\d{6,30}"
    End With
  End If
  Dim m, ms, t$, i%, k%, Arr()
  Set ms = re.Execute(text)
  If ms.Count Then
    ReDim Arr(ms.Count - 1)
    For i = 0 To ms.Count - 1
      Arr(i) = ms(i)
    Next
    scraper = Arr
  End If
End Function

Em cảm ơn Anh nhiều!
Code Anh đã tách hết các trường hợp.

Em cảm ơn Anh nhiều!