Code lấy giá trị của 4 hoặc 5 số cuối.

[LuuAnh980]

Chào các anh!!!
Em có file này, chủ yếu lấy những giá trị của 4 số hoặc 5 số không phải là "6000", "12000", và nhỏ hơn hoặc bằng 3000.
Nhưng trong cột F code không lấy giá trị "8X1500X10500" , mặc dù cột D có giá trị "8X1500X10500" cell D193, em bôi màu ạ.
Mong các anh giúp.

 

[bebo021999]

Code của bạn:
1- Dòng này chỉ lấy 4 ký tự, do đó các giá trị từ 10000 trở lên sẽ không có
valueEnd = Right(cell.Value, 4)
2- Code thao tác trực tiếp trên cell của sheet, nên dữ liệu lớn sẽ bị chậm

Do vậy dùng cái này nhé

Option Explicit
Sub FilterData()
Dim i&, j&, val, rng, res(1 To 100000, 1 To 1)
rng = Range("D4:D" & Cells(Rows.Count, "D").End(xlUp).Row).Value
For i = 1 To UBound(rng)
    val = Right(rng(i, 1), 5)
    If Left(val, 1) = "X" Then val = Right(val, 4)
    val = CDbl(val)
    Select Case val
        Case Is <= 3000, 6000, 12000
        Case Else
            j = j + 1: res(j, 1) = rng(i, 1)
    End Select
Next
With Range("F4")
    .Resize(10000, 1).ClearContents
    .Resize(j, 1).Value = res
End With
End Sub

 

[LuuAnh980]

Dạ,em cám ơn anh @bebo021999 nhiều ạ.
Em mới coi lại, code anh @bebo021999 không filter duy nhất anh ơi, 8X1500X5030 có 2 lần anh ơi.

 

[Hai Lúa Miền Tây]

Chào các anh!!!
Em có file này, chủ yếu lấy những giá trị của 4 số hoặc 5 số không phải là "6000", "12000", và nhỏ hơn hoặc bằng 3000.
Nhưng trong cột F code không lấy giá trị "8X1500X10500" , mặc dù cột D có giá trị "8X1500X10500" cell D193, em bôi màu ạ.
Mong các anh giúp.

Kết quả ra như sau phải không bạn?

4X1500X3080

4X1500X3260

4X1500X4030

4X1500X4240

4X1500X4350

4X1500X4460

4X1500X4760

4X1500X4795

4X1500X4810

4X1500X4830

4X1500X5000

4X1500X5220

8X1500X10040

8X1500X10360

8X1500X10500

8X1500X11385

8X1500X5030

8X1500X6550

8X1500X6900

8X1500X7520

8X1500X7760

8X1500X7830

8X1500X8340

8X1500X8570

8X1500X8800

8X1500X8835

8X1500X8935

8X1500X9030

8X1500X9130

8X1500X9700

 

[LuuAnh980]

Dạ lấy giá tri duy nhất thôi ạ.

 

[Hai Lúa Miền Tây]

Dạ lấy giá tri duy nhất thôi ạ.

Giá trị duy nhất như thế nào bạn? Kết quả bài trên là duy nhất rồi còn gì.

 

[HeSanbi]

Bạn xem mã dưới đây đúng ý muốn của bạn không

Sub FilterData()

  Dim rng As Range, target As Range, a, p, lr&, d As Object, i&, k&
  Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = 1
  Set rng = Range("D4").resize(ActiveSheet.UsedRange.Rows.Count,1)
  a = rng.Value: i = 1: lr = UBound(a)
  Set target = Range("L21")
  Do
    If CStr(a(i, 1)) Like "*[Xx]*" Then
      If Not d.exists(a(i, 1)) Then
        p = Split(a(i, 1), "x", , 1)
        Select Case CDec(p(UBound(p)))
        Case 6000, 12000, Is <= 3000:
        Case Else: d.Add a(i, 1), 0
        End Select
      End If
    End If
    i = i + 1
  Loop Until i > lr
  target.Resize(lr).ClearContents
  If d.Count Then target.Resize(d.Count).Value = Application.Transpose(d.keys)
End Sub

 

[bebo021999]

Dạ,em cám ơn anh @bebo021999 nhiều ạ.
Em mới coi lại, code anh @bebo021999 không filter duy nhất anh ơi, 8X1500X5030 có 2 lần anh ơi.

Vì bạn không yêu cầu từ đầu.
Thử lại, thêm cái dic vào nhé

Option Explicit
Sub FilterData()
Dim i&, j&, val, rng, res(1 To 100000, 1 To 1)
Dim dic As Object
Set dic = CreateObject("Scripting.Dictionary")
rng = Range("D4:D" & Cells(Rows.Count, "D").End(xlUp).Row).Value
For i = 1 To UBound(rng)
    val = Right(rng(i, 1), 5)
    If Left(val, 1) = "X" Then val = Right(val, 4)
    val = CDbl(val)
    Select Case val
        Case Is <= 3000, 6000, 12000
        Case Else
            If Not dic.Exits(rng(i, 1)) Then
                dic.Add rng(i, 1), ""
                j = j + 1: res(j, 1) = rng(i, 1)
            End If
    End Select
Next
With Range("F4")
    .Resize(10000, 1).ClearContents
    .Resize(j, 1).Value = res
End With
End Sub

 

[LuuAnh980]

Em có thử code của anh @HeSanbi thì lỗi như sau:


Code của anh @bebo021999 thì lỗi như sau:


Mong các anh giúp.

 

[Thóc Sama]

Em có thử code của anh @HeSanbi thì lỗi như sau:
View attachment 303615
View attachment 303616
Code của anh @bebo021999 thì lỗi như sau:
View attachment 303617
View attachment 303618
Mong các anh giúp.

Mình thấy có lỗi chính tả ở đây.

 If Not dic.Exits(rng(i, 1)) Then

bạn thêm chữ s như sau:

 If Not dic.Exists(rng(i, 1)) Then

xem được không nhé!

 

[HeSanbi]

Sửa lại compareMode = 1 bạn nhé

 

[LuuAnh980]

Filter qua F4 nha anh @HeSanbi , em không biết chỉnh code.

Bài đã được tự động gộp: 31/8/24

Code của anh @bebo021999 đúng là do lỗi chính tả ạ, cám ơn anh @Thóc Sama đã chỉ.
Cám ơn anh @bebo021999 và anh @Thóc Sama ạ.

 

[LuuAnh980]

code của anh @HeSanbi lấy không đúng anh ơi: lấy cả 6000,12000, <=3000 luôn

 

[HeSanbi]

Thêm ràng buộc Case Else bạn nhé

 

[LuuAnh980]

Sub FilterData()
  Dim rng As Range, a, p, lr&, d As Object, i&, k&, rng1 As Range
  Set d = CreateObject("Scripting.Dictionary"): d.CompareMode = 1
  Set rng = Range("D4:D220")
  Set rng1 = Range("L21:L220")
  a = rng.Value: i = 1: lr = UBound(a)
  Do
    If CStr(a(i, 1)) Like "*[Xx]*" Then
      If Not d.exists(a(i, 1)) Then
        p = Split(a(i, 1), "x", , 1)
        Select Case CDec(p(UBound(p)))
        Case 6000, 12000, Is <= 3000:
        Case Else: d.Add a(i, 1), 0
        End Select
      End If
    End If
    i = i + 1
  Loop Until i > lr
  rng1.ClearContents
  If d.Count Then rng1.Resize(d.Count).Value = Application.Transpose(d.keys)
End Sub

Code của anh @HeSanbi , em muốn gán kết quả Filter vào L21, em có chỉnh code lại, anh coi như vậy có được không ạ.

 

[VetMini]

Case thì 0 To 3000 chứ ai lại so <= 3000

Để lấy giá trị cuối sau dấu "X" thì dùng hàm InStrRev(chuỗi, "X", vbTextCompare)
Hoặc nếu chỉ cần thỏa điều kiện thì dùng Regex
"[Xx](([012]?\d{0,3})|3000|6000|12000)$"

 

[VetMini]

Code:

Sub LocTumLum()
Set rx = CreateObject("VBScript.Regexp") ' dung de loc
With rx
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "[Xx](([012]?\d{0,3})|3000|6000|12000)$"
End With
Set dic = CreateObject("Scripting.Dictionary") ' dung de lay ma unnique
dic.Comparemode = vbTextCompare
For Each cll In Range("d4:d" & Cells(Rows.Count, "D").End(xlUp).Row)
If rx.test(cll.Value) Then dic(cll.Value) = ""
Next cll
Range("L21").Resize(dic.Count) = Application.Transpose(dic.keys)
End Sub

 

[ptm0412]

Code:

Sub LocTumLum()

Anh cũng ngứa tay hay là lễ nghỉ ở nhà chán quá? Hay là tôi vác Power query ra quánh luôn 1 bài?

 

[VetMini]

Anh cũng ngứa tay hay là lễ nghỉ ở nhà chán quá? Hay là tôi vác Power query ra quánh luôn 1 bài?

Không hẳn vậy. Toi chỉ giới thiệu rằng cái kiểu lọc bằng regex nó dễ chỉnh sửa hơn - trừ phi bên kia đưa điều kiện lọc khủng. Ở GPE này, nhiều chuyện khủng lắm.
GPE đáng lẽ lấy tên GPEK (K= khủng)

 

[ptm0412]

Không hẳn vậy.

Thôi kệ, tôi múa cái hàm let vậy

=LET(a,D4:D201,b,--TEXTAFTER(a,"X",-1),c,FILTER(a,(b>3000)*(b<>6000)*(b<>12000)),d,UNIQUE(c),d)