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

Quảng cáo

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia ngày
17 Tháng tư 2016
Bài viết
2,543
Được thích
2,146
Điểm
1,368
Tuổi
29
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!
 

File đính kèm

  • tap lam.xlsx
    20.6 KB · Đọc: 43

phuongvq123

Thành viên tiêu biểu
Tham gia ngày
15 Tháng tư 2020
Bài viết
427
Được thích
269
Điểm
118
Tuổi
25
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!
bài này khó quá
 

Binbo2020

Thành viên tiêu biểu
Tham gia ngày
10 Tháng mười một 2011
Bài viết
604
Được thích
561
Điểm
568
Tuổi
37
Cái bài này hình như hôm qua có đăng trên FB thì phải, mình có xem và thấy quy cách mã code không giống nhau (số ký tự mã là khác nhau 8-13...), quy luật thì thấy lung tung quá, chỉ thấy có điểm chung là những tên hàng giống nhau đang có cùng code, tức là đang hiểu nó có một bảng mã các hàng có sẵn rồi. Giờ nếu lấy được bảng tất cả các mã ra được thì dò xem trong ô đấy có mã nào thì lấy ra thôi. Chưa nghĩ ra cách nào hay hơn vì nhìn không ra quy luật nào khác
 

vanaccex

Thành viên tiêu biểu
Tham gia ngày
8 Tháng bảy 2018
Bài viết
419
Được thích
269
Điểm
218
Em Vân tập thử làm, anh xem thử
Mã:
Function ReGexChuoi_Pos(aChuoi As String, regexPattern As String, Pos As Long) As String
    Dim regExs As Object, Matches As Object, aKetQua As Variant, i As Long
    Set regExs = CreateObject("vbscript.regexp")
    With regExs
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = regexPattern
    End With
    If regExs.Test(aChuoi) Then
        Set Matches = regExs.Execute(aChuoi)
        Set TheMatches = regExs.Execute(aChuoi)
        If IsMissing(Pos) Then
            ReDim aKetQua(0 To Matches.Count - 1) As String
            For i = 0 To UBound(Matches.Count)
                aKetQua(i) = Matches.Item(i)
            Next
            ReGexChuoi_Pos = Join(aKetQua, ",")
        Else
            Select Case Pos
                Case 0
                    ReGexChuoi_Pos = Matches(Matches.Count - 1)
                Case 1 To Matches.Count
                    ReGexChuoi_Pos = Matches(Pos - 1)
                Case Else
                    ReGexChuoi_Pos = ""
            End Select
        End If
    Else
       ReGexChuoi_Pos = ""
    End If
End Function
 

File đính kèm

  • tap lam.xlsm
    40.2 KB · Đọc: 11
Lần chỉnh sửa cuối:

Nhattanktnn

Thành viên tích cực
Tham gia ngày
11 Tháng mười một 2016
Bài viết
1,582
Được thích
1,527
Điểm
668

HeSanbi

Thành viên gắn bó
Tham gia ngày
24 Tháng hai 2013
Bài viết
1,643
Được thích
1,933
Điểm
868
Bạn có thể sử dụng một số ràng buộc như có dấu nháy đơn, có xuống dòng, có dấu cách đi đôi với (-_) kết hợp với số
Bạn sao chép code bên dưới vào một module mới
và gõ công thức vào ô B5:
=S_Scraper(A5:A5000)

JavaScript:
Option Explicit
#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
#If Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
Private Args(), WorkIndex As Integer

Function S_Scraper(ByVal target As Range) As Variant
  On Error Resume Next
  Dim k As Integer, i%, R, t$
  Set R = Application.Caller
  S_Scraper = scraper(target(1, 1).Value)(0)
  t = R.Formula
  k = UBound(Args)
  If k > 0 Then
    For i = 1 To k
      If Args(i)(3) = t And Args(i)(1) = 0 Then
        Exit Function
      End If
    Next
  End If
  ReDim Preserve Args(1 To k + 1)
  Args(k + 1) = VBA.Array(R, 0, target, t)
  If gTimerID = 0 Then gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Scraper_callback)
End Function

Private Sub S_Scraper_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  S_Scraper_callback2
  On Error GoTo 0
End Sub

Private Sub S_Scraper_callback2()
  On Error Resume Next
  Dim UA%, s$, a
  UA = UBound(Args)
  If UA > 0 Then
    WorkIndex = WorkIndex + 1
    a = Args(WorkIndex)
    If a(1) = 0 And a(0).Formula = a(3) Then
      Dim R&, R1, C%, LR&, LR2&, Arr, total$(), total2$(), cols%, ub2%, t, re As Object
      LR = a(2)(a(2).Rows.Count + 2, 1).End(3).Row - a(2).Row + 1

      If LR > 0 Then
        Set R1 = a(0).Parent.UsedRange
        LR2 = R1.Row + R1.Rows.Count - 1 - a(0)(1, 1).Row
        If LR2 < LR Then LR2 = LR
        Arr = a(2)(1, 1).Resize(LR, 1).Value
        t = scraper(Arr(1, 1), re)
        ub2 = UBound(t)
        If ub2 > 0 Then
          ReDim total2(1 To ub2)
          For C = 1 To ub2
            total2(C) = t(C)
          Next
          a(0)(1, 2).Resize(1, ub2).Value = total2
        End If

        For R = 2 To LR
          t = scraper(Arr(R, 1), re)
          ub2 = UBound(t) + 1
          If ub2 > cols Then
            cols = ub2
            ReDim Preserve total(1 To LR2, 1 To cols)
          End If
          For C = 1 To ub2
            total(R - 1, C) = t(C - 1)
          Next
        Next
        a(0)(2, 1).Resize(LR2, cols).Value = total
      End If
      a(1) = 1
    End If
    If WorkIndex >= UA Then
      Erase Args: WorkIndex = 0: Set re = Nothing
    Else
      gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Scraper_callback): Exit Sub
    End If
  End If
  On Error GoTo 0
End Sub

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 = "([\n':-] +(\d{4,30}))|((\d{4,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
      For k = 0 To 1
        t = ms(i).submatches(k * 2 + 1)
        If t <> vbNullString Then
          Arr(i) = t
          Exit For
        End If
      Next
    Next
    scraper = Arr
  End If
End Function
 
Lần chỉnh sửa cuối:

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia ngày
17 Tháng tư 2016
Bài viết
2,543
Được thích
2,146
Điểm
1,368
Tuổi
29
Bạn có thể sử dụng một số ràng buộc như có dấu nháy đơn, có xuống dòng, có dấu cách đi đôi với (-_) kết hợp với số
Bạn sao chép code bên dưới vào một module mới
và gõ công thức vào ô B5:
=S_Scraper(A5:A5000)

JavaScript:
Option Explicit
#If VBA7 Then
  Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As LongPtr, ByVal lpTimerFunc As LongPtr) As Long
  Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal HWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
  Private Declare Function SetTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
  Private Declare Function KillTimer Lib "user32" (ByVal HWnd As Long, ByVal nIDEvent As Long) As Long
#End If
#If Win64 Then
  Private gTimerID As LongPtr
#Else
  Private gTimerID As Long
#End If
Private Args(), WorkIndex As Integer

Function S_Scraper(ByVal target As Range) As Variant
  On Error Resume Next
  Dim k As Integer, i%, R, t$
  Set R = Application.Caller
  S_Scraper = scraper(target(1, 1).Value)(0)
  t = R.Formula
  k = UBound(Args)
  If k > 0 Then
    For i = 1 To k
      If Args(i)(3) = t And Args(i)(1) = 0 Then
        Exit Function
      End If
    Next
  End If
  ReDim Preserve Args(1 To k + 1)
  Args(k + 1) = VBA.Array(R, 0, target, t)
  If gTimerID = 0 Then gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Scraper_callback)
End Function

Private Sub S_Scraper_callback()
  On Error Resume Next
  Call KillTimer(0&, gTimerID): gTimerID = 0
  S_Scraper_callback2
  On Error GoTo 0
End Sub

Private Sub S_Scraper_callback2()
  On Error Resume Next
  Dim UA%, s$, a
  UA = UBound(Args)
  If UA > 0 Then
    WorkIndex = WorkIndex + 1
    a = Args(WorkIndex)
    If a(1) = 0 And a(0).Formula = a(3) Then
      Dim R&, R1, C%, LR&, LR2&, Arr, total$(), total2$(), cols%, ub2%, t, re As Object
      LR = a(2)(a(2).Rows.Count + 2, 1).End(3).Row - a(2).Row + 1

      If LR > 0 Then
        Set R1 = a(0).Parent.UsedRange
        LR2 = R1.Row + R1.Rows.Count - 1 - a(0)(1, 1).Row
        If LR2 < LR Then LR2 = LR
        Arr = a(2)(1, 1).Resize(LR, 1).Value
        t = scraper(Arr(1, 1), re)
        ub2 = UBound(t)
        If ub2 > 0 Then
          ReDim total2(1 To ub2)
          For C = 1 To ub2
            total2(C) = t(C)
          Next
          a(0)(1, 2).Resize(1, ub2).Value = total2
        End If

        For R = 2 To LR
          t = scraper(Arr(R, 1), re)
          ub2 = UBound(t) + 1
          If ub2 > cols Then
            cols = ub2
            ReDim Preserve total(1 To LR2, 1 To cols)
          End If
          For C = 1 To ub2
            total(R - 1, C) = t(C - 1)
          Next
        Next
        a(0)(2, 1).Resize(LR2, cols).Value = total
        Set re = Nothing
      End If
      a(1) = 1
    End If
    If WorkIndex >= UA Then
      Erase Args: WorkIndex = 0
    Else
      gTimerID = SetTimer(0&, 0&, 1, AddressOf S_Scraper_callback): Exit Sub
    End If
  End If
  On Error GoTo 0
End Sub

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 = "([\n'-](\d{4,30}))|((\d{4,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
      For k = 0 To 1
        t = ms(i).submatches(k * 2 + 1)
        If t <> vbNullString Then
          Arr(i) = t
          Exit For
        End If
      Next
    Next
    scraper = Arr
  End If
End Function
Anh xem thử trường hợp trước những con số không có dấu ' thì sẽ không tách được chuỗi đó.
Anh xem trong file đính kèm em có đánh dấu để Anh xem.

Em cảm ơn Anh!
 

File đính kèm

  • test.xlsm
    37.5 KB · Đọc: 7

HeSanbi

Thành viên gắn bó
Tham gia ngày
24 Tháng hai 2013
Bài viết
1,643
Được thích
1,933
Điểm
868

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia ngày
17 Tháng tư 2016
Bài viết
2,543
Được thích
2,146
Điểm
1,368
Tuổi
29
Sao dòng 16 & 21 không có kết quả?
Em xin trả lởi Anh. Em chỉ làm ví dụ minh họa để tách chuỗi đó thôi. Ví dụ giống như dòng 21 anh hỏi là những dữ liệu này có người làm file rồi gửi xuống bộ phận bên em. Có lúc thì có dữ liệu có lúc thì không? Em xin lỗi anh nhắc nhở em mới nhớ.
 
Quảng cáo
Top Bottom