VBA - Viết Code lọc dữ liệu ? (1 người xem)

khongaicanobody · 6/5/13

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

vu_tuan_manh_linh · 6/5/13

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

PHP:

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

Hai Lúa Miền Tây · 6/5/13

khongaicanobody đã viết:
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

Bạn dùng code sau:

[GPECODE=sql]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

[/GPECODE]

vu_tuan_manh_linh · 6/5/13

Hai Lúa Miền Tây đã viết:
Bạn dùng code sau:

[GPECODE=sql]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

[/GPECODE]

Code của bác Hai lúa "hàn lâm" quá, em đọc chả hiểu gì cả!!

hoamattroicoi · 6/5/13

vu_tuan_manh_linh đã viết:

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

PHP:

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 :

PHP:

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 = "* " & .[E12].Value
    Set LastCell = .Cells(.Rows.Count, 1).End(xlUp)
     
    Set rngS = .Range(.[A4], 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

Quang_Hải · 6/5/13

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

PHP:

Sub LOC()
[IV2] = [A3]: [IV3] = "*" & [A1]
[A3:A1000].AdvancedFilter 2, [IV2:IV3], [C3]
End Sub

Quang_Hải · 6/5/13

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 ý

PHP:

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

Ngoai Thanh · 7/5/13

quanghai1969 đã viết:
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

PHP:

Sub LOC() [IV2] = [A3]: [IV3] = "*" & [A1] [A3:A1000].AdvancedFilter 2, [IV2:IV3], [C3] End Sub

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

Hai Lúa Miền Tây · 7/5/13

Ngoai Thanh đã viết:
xin Quang Hải giải thích 2 địa chỉ [IV2] và [IV3] . xin cám ơn !

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

Ngoai Thanh · 7/5/13

Hai Lúa Miền Tây đã viết:
Đó 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 .

khongaicanobody · 7/5/13

Anh quanghai1969 ơ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?

Cám ơn anh.

hungpecc1 · 7/5/13

khongaicanobody đã viết:
Anh quanghai1969 ơ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?

Cám ơn anh.

Code của anh Quang Hải như sau :
[GPECODE=vb]
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
[/GPECODE]
Bạn sửa lại dòng 4 :

PHP:

dk = UCase([a1])

thành

PHP:

dk = UCase(sheet2.[a1])

vu_tuan_manh_linh · 8/5/13

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???

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

PHP:

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

dhn46 · 8/5/13

Mình thấy sử dung Like có vẻ đơn giản hơn. Dhn46 mượn Code anh Hải để dùng Like

Mã:

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

dhn46 · 8/5/13

quanghai1969 đã viết:
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 ý

PHP:

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

Hai Lúa Miền Tây · 8/5/13

dhn46 đã viết:
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.

Mã:

Function tachten(ten As Variant)
   With CreateObject("vbscript.regexp")
      .Pattern = ".*\s"
      tachten = .Replace([B][COLOR=#ff0000]Trim[/COLOR][/B](ten), "")
   End With
End Function

dhn46 · 8/5/13

Hai Lúa Miền Tây đã viết:
Thì ta dùng hàm Trim là được.

Mã:

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

Mã:

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

Hai Lúa Miền Tây · 8/5/13

dhn46 đã viết:
Nếu không Trim thì anh thử Code sau

Mã:

Function tachten(ten As Variant) With CreateObject("vbscript.regexp") .Pattern = ".*\s|\s*$" tachten = .Replace([B][COLOR=#ff0000]Trim[/COLOR][/B](ten), "") End With End Function

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

hungpecc1 · 8/5/13

Cái bài này sao giống cái bài anh Hải xài ở " Đố Vui VBA " vậy !
[GPECODE=vb]
Sub LOC()
[IV2] = [A3]: [IV3] = "'=* " & [A1]
[A3:A1000].AdvancedFilter 2, [IV2:IV3], [C3]
End Sub
[/GPECODE]

Hai Lúa Miền Tây · 8/5/13

hungpecc1 đã viết:
Cái bài này sao giống cái bài anh Hải xài ở " Đố Vui VBA " vậy !
[GPECODE=vb]
Sub LOC()
[IV2] = [A3]: [IV3] = "'=* " & [A1]
[A3:A1000].AdvancedFilter 2, [IV2:IV3], [C3]
End Sub
[/GPECODE]

Từ bài này ra cái đố vui ấy mà. Xem dữ liệu là biết liền.

dhn46 · 8/5/13

Hai Lúa Miền Tây đã viết:
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.)

Mã:

Function tachten(ten As Variant)
   With CreateObject("vbscript.regexp")
      .Pattern = "\w+\s*$"
      tachten = .Execute(ten).Item(0).Value
   End With
End Function

VBA - Viết Code lọc dữ liệu ? (1 người xem)

Người dùng đang xem chủ đề này

Thành viên mới

File đính kèm

linhvtm84@gmail.com

❆❆❆❆❆❆❆❆

File đính kèm

linhvtm84@gmail.com

Thành viên gắn bó

File đính kèm

Thành viên gạo cội

File đính kèm

Thành viên gạo cội

Cánh Diều xanh

❆❆❆❆❆❆❆❆

Cánh Diều xanh

Thành viên mới

Thành viên gắn bó

linhvtm84@gmail.com

Hướng tới tương lai

Hướng tới tương lai

❆❆❆❆❆❆❆❆

Hướng tới tương lai

❆❆❆❆❆❆❆❆

Thành viên gắn bó

❆❆❆❆❆❆❆❆

Hướng tới tương lai

Thời gian đếm ngược.