VBA – Viết Code lọc dữ liệu ?

Chia sẻ bởi:hands

★★★★★

‹ Xin giúp, tự động gửi mail theo... Khóa Header and Footer ›

Quảng cáo

Cám ơn mọi người

Kính gửi các anh chị.

Mình có một danh sách về tên người. Mình muốn gõ một số chữ thì được một danh sách của các dòng có chứa tên của chữ đó (Xem file đính kèm). như vậy phải làm sao?

Rất mong được các anh chị hỗ trợ.

Cám ơn mọi người

Thử đoạn code này xem có được không bạn!

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer, j As Integer
Dim Kq(1 To 1000) As String
Application.ScreenUpdating = False
If Target.Address = "$E$12" Then
For i = 1 To Range("A65536").End(xlUp).Row
If InStr(1, Cells(i, 1).Value, Target.Value) Then
j = j + 1
Kq(j) = Cells(i, 1).Value
End If
Next i
Range("H9:H65536").ClearContents
For i = 1 To j
Cells(9 + i, 8).Value = Kq(i)
Next i
End If
Application.ScreenUpdating = True
End Sub

www.giaiphapexcel.com/diendan/threads/vba-vi%E1%BA%BFt-code-l%E1%BB%8Dc-d%E1%BB%AF-li%E1%BB%87u.80342/

Khóa học SprinGO phù hợp

Học Nhân sự Tổng hợp – Trở thành chiến binh nhân sự vững nghiệp vụ

Con người là một trong những yếu tố quan trọng của công ty, là tài sản quý giá của doanh nghiệp. Chính vì thế,...

Xem khóa học

★★★★★ 5 ★ 1 👤 11 ▥ 0

‹ Xin giúp, tự động gửi mail theo giờ... Khóa Header and Footer ›

Quảng cáo

Bạn nên đọc

11 Responses

hands says:

08/12/2023 at 5:36 pm

Bạn dùng code sau:

Sub Loc_HLMT()
Dim adoConn As Object, adoRS As Object
    Set adoConn = CreateObject("ADODB.Connection")
    Set adoRS = CreateObject("ADODB.Recordset")
    With adoConn
        .ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                            "Data Source=" & ThisWorkbook.FullName & _
                            ";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
        .Open
    End With
    With adoRS
        .ActiveConnection = adoConn
        .Open "select f1 from [Sheet1$A4:A1000] " _
                & "where f1 like '%" & Sheet1.Range("E12").Value & "'"
    End With
    With Sheet1
        .[H8:H65000].ClearContents
        .[H10].CopyFromRecordset adoRS
    End With
    adoRS.Close: Set adoRS = Nothing
    adoConn.Close: Set adoConn = Nothing

End Sub

hands says:

08/12/2023 at 5:37 pm

Thử đoạn code này xem có được không bạn!

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer, j As Integer
Dim Kq(1 To 1000) As String
Application.ScreenUpdating = False
If Target.Address = "$E$12" Then
For i = 1 To Range("A65536").End(xlUp).Row
If InStr(1, Cells(i, 1).Value, Target.Value) Then
j = j + 1
Kq(j) = Cells(i, 1).Value
End If
Next i
Range("H9:H65536").ClearContents
For i = 1 To j
Cells(9 + i, 8).Value = Kq(i)
Next i
End If
Application.ScreenUpdating = True
End Sub

Trường hợp lọc tên Ngọc nhưng trong vùng lọc có tên Trần Ngọc Thiên Kim thì code của bạn sẽ liệt kê cả tên này ra trong khi ta chỉ muốn lọc những người tên là Ngọc, gõ ngọc thì code cũng không nhận dạng được để lọc??? Mình đề xuất code thế này :
Sub LocDK_Ten()

Dim Rng As Range, j As Long
Dim FrsAdd As String, Ten As String
Dim LastCell As Range, rngS As Range

With Sheet1
.Range("H10:H100").ClearContents
Ten = "* " & ..Value
Set LastCell = .Cells(.Rows.Count, 1).End(xlUp)

Set rngS = .Range(., LastCell)
Set Rng = rngS.Find(What:=Ten, after:=LastCell, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Rng Is Nothing Then
MsgBox "Khong có gia tri tim kiem trong vung"
Else
FrsAdd = Rng.Address
j = 9
Do
j = j + 1
.Cells(j, 8) = Rng
Set Rng = rngS.FindNext(after:=Rng)
Loop Until FrsAdd = Rng.Address
End If
End With
End Sub

Reply
hands says:

08/12/2023 at 5:37 pm

Góp vui code này. Mặc dù thấy ngắn thế nhưng hiệu quả lắm nha.
Code này cũng được xếp vô dạng tuyệt chiêu nghen

Sub LOC()
= : = "*" &
.AdvancedFilter 2, ,
End Sub

Reply
hands says:

08/12/2023 at 5:37 pm

Góp vui code này. Mặc dù thấy ngắn thế nhưng hiệu quả lắm nha.
Code này cũng được xếp vô dạng tuyệt chiêu nghen

Sub LOC()
= : = "*" &
.AdvancedFilter 2, ,
End Sub

Thử dùng hàm hỗ trợ thử xem. Đây là lần đầu tiền dùng hàm ghép với Sub, mong được anh chị góp ý

Sub LOC()
Dim data(), kq(1 To 1000, 1 To 1)
Dim i As Long, k As Long, dk As String
dk = UCase()
data = Range(, .End(3)).Value
For i = 1 To UBound(data)
If data(i, 1) <> "" Then
If UCase(tachten(data(i, 1))) = dk Then
k = k + 1
kq(k, 1) = (data(i, 1))
End If
End If
Next
.ClearContents
If k Then .Resize(k) = kq
End Sub

Function tachten(ten As Variant)
With CreateObject("vbscript.regexp")
.Pattern = ".*s"
tachten = .Replace(ten, "")
End With
End Function

Reply
hands says:

08/12/2023 at 5:38 pm

Góp vui code này. Mặc dù thấy ngắn thế nhưng hiệu quả lắm nha.
Code này cũng được xếp vô dạng tuyệt chiêu nghen

Sub LOC()
= : = "*" &
.AdvancedFilter 2, ,
End Sub

xin Quang Hải giải thích 2 địa chỉ và . xin cám ơn !

Đó là vùng phụ để làm điều kiện lọc ý mà.

Reply
hands says:

08/12/2023 at 5:38 pm

Đó là vùng phụ để làm điều kiện lọc ý mà.

cám ơn thày Hai lúa, té ra nó là cột cuối , em chả bao giờ thử đến đây, đúng là "Mũi cà mau" ivê , cứ tưởng số la mã nên thấy nó lạ hoắc .Anh [URL='https://www.giaiphapexcel.com/forum/member.php?u=134916'%5Dquanghai1969 ơi, khi em muốn chuyển ô gõ chữ A1 sang 1 sheet khác, chẳng hạn như là sheet2 thì code phải làm thế nào?

Code của anh Quang Hải như sau :
```
Sub LOC()
Dim data(), kq(1 To 1000, 1 To 1)
Dim i As Long, k As Long, dk As String
dk = UCase([a1])
data = Range([A4], [A65536].End(3)).Value
For i = 1 To UBound(data)
   If data(i, 1) <> "" Then
      If UCase(tachten(data(i, 1))) = dk Then
         k = k + 1
         kq(k, 1) = (data(i, 1))
      End If
   End If
Next
[C4:C1000].ClearContents
If k Then [C4].Resize(k) = kq
End Sub

Function tachten(ten As Variant)
   With CreateObject("vbscript.regexp")
      .Pattern = ".*s"
      tachten = .Replace(ten, "")
   End With
End Function
```
Bạn sửa lại dòng 4 :
dk = UCase()
thành dk = UCase(sheet2.)

Reply
hands says:

08/12/2023 at 5:39 pm

Trường hợp lọc tên Ngọc nhưng trong vùng lọc có tên Trần Ngọc Thiên Kim thì code của bạn sẽ liệt kê cả tên này ra trong khi ta chỉ muốn lọc những người tên là Ngọc, gõ ngọc thì code cũng không nhận dạng được để lọc??? Mình đề xuất code thế này :
Sub LocDK_Ten()

Dim Rng As Range, j As Long
Dim FrsAdd As String, Ten As String
Dim LastCell As Range, rngS As Range

With Sheet1
.Range("H10:H100").ClearContents
Ten = "* " & ..Value
Set LastCell = .Cells(.Rows.Count, 1).End(xlUp)

Set rngS = .Range(., LastCell)
Set Rng = rngS.Find(What:=Ten, after:=LastCell, LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
If Rng Is Nothing Then
MsgBox "Khong có gia tri tim kiem trong vung"
Else
FrsAdd = Rng.Address
j = 9
Do
j = j + 1
.Cells(j, 8) = Rng
Set Rng = rngS.FindNext(after:=Rng)
Loop Until FrsAdd = Rng.Address
End If
End With
End Sub

Em sửa lại thế này thấy lọc được theo ý trên:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Integer, j As Integer
Dim Kq(1 To 1000) As String
Application.ScreenUpdating = False
If Target.Address = "$E$12" Then
For i = 1 To Range("A65536").End(xlUp).Row
If Cells(i, 1).Value <> "" Then
If LCase(Right(Cells(i, 1).Value, Len(Target.Value))) = LCase(Target.Value) And _
Mid(Cells(i, 1).Value, Len(Cells(i, 1).Value) – Len(Target.Value), 1) = Chr(32) Then
j = j + 1
Kq(j) = Cells(i, 1).Value
End If
End If
Next i
Range("H9:H65536").ClearContents
For i = 1 To j
Cells(9 + i, 8).Value = Kq(i)
Next i
End If
Application.ScreenUpdating = True
End Sub

Mình thấy sử dung Like có vẻ đơn giản hơn. Dhn46 mượn Code anh Hải để dùng Like
```
Sub LOC()
Dim data(), kq(1 To 1000, 1 To 1)
Dim i As Long, k As Long, dk As String
dk = UCase([a1])
data = Range([A4], [A65536].End(3)).Value
For i = 1 To UBound(data)
   If data(i, 1) <> "" Then
      If UCase(data(i, 1)) Like "*" & dk Then
         k = k + 1
         kq(k, 1) = (data(i, 1))
      End If
   End If
Next
[C4:C1000].ClearContents
If k Then [C4].Resize(k) = kq
End Sub
```
Reply
hands says:

08/12/2023 at 5:39 pm

Thử dùng hàm hỗ trợ thử xem. Đây là lần đầu tiền dùng hàm ghép với Sub, mong được anh chị góp ý

Sub LOC()
Dim data(), kq(1 To 1000, 1 To 1)
Dim i As Long, k As Long, dk As String
dk = UCase()
data = Range(, .End(3)).Value
For i = 1 To UBound(data)
If data(i, 1) <> "" Then
If UCase(tachten(data(i, 1))) = dk Then
k = k + 1
kq(k, 1) = (data(i, 1))
End If
End If
Next
.ClearContents
If k Then .Resize(k) = kq
End Sub

Function tachten(ten As Variant)
With CreateObject("vbscript.regexp")
.Pattern = ".*s"
tachten = .Replace(ten, "")
End With
End Function

Code tách tên này của anh Hải sẽ sai nếu có dấu cách phía sau họ tên

Thì ta dùng hàm Trim là được.
```
Function tachten(ten As Variant)
   With CreateObject("vbscript.regexp")
      .Pattern = ".*s"
      tachten = .Replace([B][COLOR=#ff0000]Trim[/COLOR][/B](ten), "")
   End With
End Function
```
Reply
hands says:

08/12/2023 at 5:39 pm
Thì ta dùng hàm Trim là được.
```
Function tachten(ten As Variant)
   With CreateObject("vbscript.regexp")
      .Pattern = ".*s"
      tachten = .Replace([B][COLOR=#ff0000]Trim[/COLOR][/B](ten), "")
   End With
End Function
```
Nếu không Trim thì anh thử Code sau
```
Function tachten(ten As Variant)
   With CreateObject("vbscript.regexp")
      .Pattern = ".*s|s*$"
      tachten = .Replace(Trim(ten), "")
   End With
End Function
```
Vậy bạn test thử khi bỏ trim nhé. Hàm trên vẫn còn trim.

Reply
hands says:

08/12/2023 at 5:40 pm

.
Cái bài này sao giống cái bài anh Hải xài ở " Đố Vui VBA " vậy !
```
Sub LOC()
[IV2] = [A3]: [IV3] = "'=* " & [A1]
[A3:A1000].AdvancedFilter 2, [IV2:IV3], [C3]
End Sub
```
Từ bài này ra cái đố vui ấy mà. Xem dữ liệu là biết liền.

Reply
hands says:

08/12/2023 at 5:40 pm

Vậy bạn test thử khi bỏ trim nhé. Hàm trên vẫn còn trim.

Vâng đúng là phải sửa anh ah. Voọc để biết thêm anh nhỉ?(Mấy cái này học có vẻ dễ hơn ADO anh Hai Lúa ah, nhìn anh viết ADO muốn nhưng chưa dám bước vào.)
```
Function tachten(ten As Variant)
   With CreateObject("vbscript.regexp")
      .Pattern = "w+s*$"
      tachten = .Execute(ten).Item(0).Value
   End With
End Function
```
Reply