Lọc dữ liệu theo nhiều điều kiện

[dangductuong2125]

Em chào các bác, các bác giúp em lọc dữ liệu với nhiều điện kiện. Vì mô tả khá dài nên các bác xem qua File chi tiết giúp em. Em cảm ơn nhiều

 

[HUONGHCKT]

Em chào các bác, các bác giúp em lọc dữ liệu với nhiều điện kiện. Vì mô tả khá dài nên các bác xem qua File chi tiết giúp em. Em cảm ơn nhiều

Tham khao code sau:
1/Trong VBE của Sheet 1 chép đoạn code này

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C7:C1000")) Is Nothing Then
    Call Loc(Target)
End If
End Sub

2/Trong module 1 chép code này

Option Explicit

Sub Loc(Rng As Range)
Dim i&, Col&
Dim KQ, S

With Sheet1
Set Rng = ActiveCell
S = Split(Rng, "@")
    For i = LBound(S) To UBound(S)
        If IsNumeric(S(i)) And Len(S(i)) = 6 Then
            If KQ = Empty Then KQ = S(i) Else KQ = KQ & "@" & S(i)
            If Len(KQ) = 13 Then Exit For
        End If
    Next i
  Col = Rng.End(xlToRight).Column + 1
 .Cells(Rng.Row, Col) = KQ
End With
End Sub

Code chưa bẫy hết lỗi, Bạn tự làm.
Hy vọng đúng ý.
Có thể code chỉ ra kết quả đúng với dữ liệu trong file giả lập,

 

[dangductuong2125]

Tham khao code sau:
1/Trong VBE của Sheet 1 chép đoạn code này

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C7:C1000")) Is Nothing Then
    Call Loc(Target)
End If
End Sub

2/Trong module 1 chép code này

Option Explicit

Sub Loc(Rng As Range)
Dim i&, Col&
Dim KQ, S

With Sheet1
Set Rng = ActiveCell
S = Split(Rng, "@")
    For i = LBound(S) To UBound(S)
        If IsNumeric(S(i)) And Len(S(i)) = 6 Then
            If KQ = Empty Then KQ = S(i) Else KQ = KQ & "@" & S(i)
            If Len(KQ) = 13 Then Exit For
        End If
    Next i
  Col = Rng.End(xlToRight).Column + 1
 .Cells(Rng.Row, Col) = KQ
End With
End Sub

Code chưa bẫy hết lỗi, Bạn tự làm.
Hy vọng đúng ý.
Có thể code chỉ ra kết quả đúng với dữ liệu trong file giả lập,

Cảm ơn bác rất nhiều. Em quên không ghi rõ thêm là đây là những mã QR code được Scan, nếu em xóa mã đó vừa Scan xong thì nó mất luôn ô đầu tiên bên trái. Em muốn khi em xóa mã đã Scan trước đó đi thay bằng mã Scan khác thì mã lọc nó tiếp tục nhảy vào ô trống tiếp theo.

 

[cantl]

Cảm ơn bác rất nhiều. Em quên không ghi rõ thêm là đây là những mã QR code được Scan, nếu em xóa mã đó vừa Scan xong thì nó mất luôn ô đầu tiên bên trái. Em muốn khi em xóa mã đã Scan trước đó đi thay bằng mã Scan khác thì mã lọc nó tiếp tục nhảy vào ô trống tiếp theo.

Tớ nghịch tí. Nhớ bật thư viện Microsoft VBScript Regular Expressions 5.5. Regex chôm của Nhattan.
Thông báo lỗi có thể bỏ tùy sở thích.
@dangductuong2125 . Sửa lại chút ở dòng Static và dấu ' dòng dưới (nếu cùng 1 mã y hệt mà nhập liên tiếp thì không chèn nữa).

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo LOI
Static giatritemp$
'giatritemp = ""
If Not Intersect(Target, Range("C7:C1000")) Is Nothing And giatritemp <> Target.Value Then
    giatritemp = Target.Value
    Cells(Target.Row, Target.End(xlToRight).Column + 1) = RegexExtract(Target.Value, "([0-9]{6}\@[0-9]{6})", 1)
End If
Exit Sub
LOI:
MsgBox "Khong co ma 13 ky tu!"
Exit Sub
End Sub

Option Explicit

Public Function RegexExtract(Value As Variant, Pattern As String, k As Long) As String
    Static objRegex As Object
    Dim colRegexMatches As Object
    'k bat dau tu 1
    If objRegex Is Nothing Then Set objRegex = CreateObject("VBScript.Regexp")
    With objRegex
        .Pattern = Pattern
        .Global = True
        .IgnoreCase = False
        .MultiLine = True
    End With
    RegexExtract = objRegex.Execute(Value)(k - 1).submatches(0)
End Function

 

[VetMini]

Tớ nghịch tí. Nhớ bật thư viện Microsoft VBScript Regular Expressions 5.5. Regex chôm của Nhattan.
Thông báo lỗi có thể bỏ tùy sở thích.

Function RegexExtract không có bẫy lỗi và gửi lỗi ngược lại cho hàm gọi nó. Và cũng không có dòng test. Vì vậy nó sẽ chết tức tưởi ngay tại chỗ nếu tìm không được.

 

[cantl]

Function RegexExtract không có bẫy lỗi và gửi lỗi ngược lại cho hàm gọi nó. Và cũng không có dòng test. Vì vậy nó sẽ chết tức tưởi ngay tại chỗ nếu tìm không được.

Em chưa hiểu lắm, không tìm được thì nó không chèn thêm gì thôi mà bác?
@dangductuong2125 . Tớ sửa lại chút ở dòng Static và dấu ' dòng dưới (nếu cùng 1 mã y hệt mà nhập liên tiếp thì không chèn nữa).
Trong lúc chờ code tốt hơn thì dùng tạm thôi.

 

[CHAOQUAY]

Cảm ơn bác rất nhiều. Em quên không ghi rõ thêm là đây là những mã QR code được Scan, nếu em xóa mã đó vừa Scan xong thì nó mất luôn ô đầu tiên bên trái. Em muốn khi em xóa mã đã Scan trước đó đi thay bằng mã Scan khác thì mã lọc nó tiếp tục nhảy vào ô trống tiếp theo.

Bài 2, sub Loc
Sửa dòng dưới

.Cells(Rng.Row, Col) = KQ

Thành dòng dưới đây xem sao

If Len(KQ) Then .Cells(Rng.Row, Col) = KQ

 

[VetMini]

Em chưa hiểu lắm, không tìm được thì nó không chèn thêm gì thôi mà bác?
...

Đây là code nguyên thủy lấy từ
https://www .ablebits.com/office-addins-blog/regex-extract-strings-excel/
(trong đó, đúng theo tinh thần netiquette, họ có nêu tên tác giả là Alex Frolov.

Public Function RegExpExtract(text As String, pattern As String, Optional instance_num As Integer = 0, Optional match_case As Boolean = True)
Dim text_matches() As String Dim matches_index As Integer
On Error GoTo ErrHandl
RegExpExtract = ""
Set regex = CreateObject("VBScript.RegExp")
regex.pattern = pattern
regex.Global = True regex.MultiLine = True
If True = match_case Then regex.ignorecase = False
Else
regex.ignorecase = True
End If
Set matches = regex.Execute(text)
If 0 < matches.Count Then
If (0 = instance_num) Then
ReDim text_matches(matches.Count - 1, 0)
For matches_index = 0 To matches.Count - 1
text_matches(matches_index, 0) = matches.Item(matches_index)
Next matches_index
RegExpExtract = text_matches
Else
RegExpExtract = matches.Item(instance_num - 1)
End If
End If
Exit Function
ErrHandl:
RegExpExtract = CVErr(xlErrValue)
End Function

 

[cantl]

Đây là code nguyên thủy lấy từ
https://www .ablebits.com/office-addins-blog/regex-extract-strings-excel/
(trong đó, đúng theo tinh thần netiquette, họ có nêu tên tác giả là Alex Frolov.

Public Function RegExpExtract(text As String, pattern As String, Optional instance_num As Integer = 0, Optional match_case As Boolean = True)
Dim text_matches() As String Dim matches_index As Integer
On Error GoTo ErrHandl
RegExpExtract = ""
Set regex = CreateObject("VBScript.RegExp")
regex.pattern = pattern
regex.Global = True regex.MultiLine = True
If True = match_case Then regex.ignorecase = False
Else
regex.ignorecase = True
End If
Set matches = regex.Execute(text)
If 0 < matches.Count Then
If (0 = instance_num) Then
ReDim text_matches(matches.Count - 1, 0)
For matches_index = 0 To matches.Count - 1
text_matches(matches_index, 0) = matches.Item(matches_index)
Next matches_index
RegExpExtract = text_matches
Else
RegExpExtract = matches.Item(instance_num - 1)
End If
End If
Exit Function
ErrHandl:
RegExpExtract = CVErr(xlErrValue)
End Function

Dài quá bác ơi. Nhưng em đang thắc mắc lỗi thì nó vẫn báo và bỏ qua không bị tức tưởi như bác đề cập mà. Cần lắm 1 lỗi ví dụ bác ơi.

 

[HUONGHCKT]

Cảm ơn bác rất nhiều. Em quên không ghi rõ thêm là đây là những mã QR code được Scan, nếu em xóa mã đó vừa Scan xong thì nó mất luôn ô đầu tiên bên trái. Em muốn khi em xóa mã đã Scan trước đó đi thay bằng mã Scan khác thì mã lọc nó tiếp tục nhảy vào ô trống tiếp theo.

Bạn đã thử chưa? Ô target ở cột C có thể xóa và paste Chuỗi khác vào thì chỉ số col cũng thay đổi mà chứ nó có là col cũ đâu mà sợ nó đè lến dữ liệu cũ.