Demo Form tìm kiếm nhiều cột trong Listbox

[ongke0711]

Form tìm kiếm listbox thì diễn đàn cũng có nhiều bài rồi nhưng nó nằm chung trong các bài hỏi của thành viên nên tìm cũng mệt . Vừa làm vừa học nên tôi tạo cái post này cho dễ tìm kiếm và nhờ các anh em giúp cải thiện cái form này cho chạy trơn tru và thuận tiện nhé.
- Form dùng tìm kiếm theo nhiều cột trong listbox. Chỉ cần gõ ký tự chuỗi bất kỳ, nó sẽ tìm trong tất cả các cột để lấy ra dòng có chứa chuỗi.
- Viết dạng hàm để có thể gọi sử dụng lại ở nhiều form.

Điểm chưa làm được:
- Chưa định dạng được dữ liệu hiển thị từng cột trong listbox (dùng mảng gán row source cho listbox). Cụ thể trong demo là cột [Đơn giá]: không có định dạng số (dấu cách phần ngàn .000).
- Chưa tuỳ chọn Sort dữ liệu tự động (theo cột đã chọn) trong listbox sau khi tìm kiếm (có tham khảo mấy hàm bubble sort trên mạng nhưng tích hợp vô).

Bạn nào chỉ cần tìm kiếm dữ liệu thì tôi nghĩ form này đáp ứng yêu cầu.
Các bạn hỗ trợ bổ sung thiết kế giùm nhé. File đính kèm bên dưới.
Cảm ơn.


Code cho Userform:

Option Explicit

Dim oRngLstBx1 As Range

Private Sub txtChuoiTK_Change()
    Dim strTextSearch As String

    strTextSearch = Me.txtChuoiTK.Value
    Call faytLstBxMultiCol(oRngLstBx1, strTextSearch, "lstDanhSachVPP", Me)

End Sub

Private Sub UserForm_Initialize()
    ganSourceListbox
    Me.txtChuoiTK.SetFocus
End Sub


Sub ganSourceListbox()

    Dim sArr() As Variant

    Set oRngLstBx1 = Range(Range("A2"), Range("A2").End(xlDown).End(xlToRight))     'Khai báo cho biesn toàn cuc de su dung cho hàm TK
    ReDim sArr(1 To oRngLstBx1.Rows.Count, 1 To oRngLstBx1.Columns.Count)

    sArr = oRngLstBx1.Value
    Me.lstDanhSachVPP.List = sArr

End Sub

- Hàm faytLstBxMultiCol():

Option Explicit

Function faytLstBxMultiCol(oLstBxRng As Range, strSearchTxt As String, strLstBxName As String, frm As UserForm) As Boolean
'----------------------------------------------------------
'# Hàm tim kiem,loc danh sach listbox theo chuoi tìm kiem.
'# oLstBxRng:       là Range làm Row Source cho Listbox.
'# strSearchTxt:    Chuoi can tim (tu textbox).
'# strLstBxName:    Ten cua listbox control tren userform.
'----------------------------------------------------------

On Error GoTo EH

    Dim sArr() As Variant
    Dim blnFound As Boolean 'bien neu tim thay chuoi can tìm
    Dim i As Long, j As Long, rCount As Long
    Dim oLstBx As Object

    faytLstBxMultiCol = False
    Set oLstBx = frm.Controls(strLstBxName)

    ReDim sArr(1 To oLstBxRng.Columns.Count, 1 To oLstBxRng.Rows.Count)

    For i = 1 To oLstBxRng.Rows.Count
        blnFound = False
        For j = 1 To oLstBxRng.Columns.Count
            If InStr(1, oLstBxRng.Cells(i, j).Value, strSearchTxt, vbTextCompare) > 0 Then  'Tim kiem chuoi tung dong, cot
                blnFound = True     'Tim thay chuoi
                Exit For
            End If
        Next j
        If blnFound Then
            rCount = rCount + 1     'Luu tong so dòng tìm hay chuoi
            For j = 1 To oLstBxRng.Columns.Count
                sArr(j, rCount) = oLstBxRng.Cells(i, j).Value   'Dua tri tim duoc vao mang, luu hang ngang
            Next j
        End If
    Next i

    'Khai bao lai kich thuoc mang theo so dong tim thay chuoi
    If rCount > 0 Then
        ReDim Preserve sArr(1 To j - 1, 1 To rCount)
    Else    'Khong tim thay dòng nào chua chuoi tk
        ReDim Preserve sArr(1 To j - 1, 1 To 1)
    End If

    If UBound(sArr, 2) > 1 Then     'Mang co nhieu gia tri giong chuoi tim kiem
        sArr = Application.WorksheetFunction.Transpose(sArr)
        oLstBx.List = sArr
    Else    'Mang tra ve chinh xác 1 giá tri tim kiem
        oLstBx.Clear
        oLstBx.AddItem
        For i = 1 To UBound(sArr)
            oLstBx.Column(i - 1, 0) = sArr(i, 1)
        Next i
    End If

    faytLstBxMultiCol = True
    Exit Function

EH_Exit:
    faytLstBxMultiCol = False
    Exit Function
EH:
    MsgBox "Loi: " & Err.Number & vbNewLine & "Noi dung loi: " & Err.Description
    Resume EH_Exit

End Function

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Bổ sung: (sau thời gian mò mẫm thêm )
- Thêm phần định các cột kiểu số (number) trong listbox với dấu phân cách hàng ngàn.
- Hàm dùng định dạng cột kiểu số trong listbox với tuỳ chọn nhiều cột.
(Đã đính kèm thêm file có định dạng cột)

Mình cũng có sưu tầm được một Class dùng để "canh lề" từng cột trong listbox riêng biệt (hiện nay Listbox chỉ cho phép canh lề một kiểu, áp dụng cho toàn bộ listbox) nhưng khi chạy thấy nó tải dữ liệu lên listbox chậm nên không đưa vô đây.
Giải thuật của các class này là xử lý từng cột -> từng record -> dùng label tạm để lưu nội dung record, thêm dấu cách vào trước, sau hoặc 2 bên để canh phải, trái, giữa rồi lưu lại nội dung vừa sửa vào listbox. Danh sách có 200 dòng mà nó chạy vòng lập cũng mất ~ 2s nên thôi bỏ qua giải pháp này.

Code hàm formatNumColumnLstBx() :

Function formatNumColumnLstBx(sLstBxName As String, sColNumList As String, frm As UserForm, sNumFormat As String)

'----------------------------------------------------------------
'# Muc dích: dùng dinh dang các cot kieu Number trong listbox và dùng trong truong hop dùng Mang (Array) gan du lieu cho LstBox.
'# Tham so:
'#   - sColNumList: danh sách các cot can dinh dang So, cách nhau dau phay ','. Vd: "4,5,6".
'#   - sNumFormat:  kieu dinh dang so. Vd: "#,##0": "#,##0.00" hoac "$#,##0.00"
'----------------------------------------------------------------

    Dim arColNumList As Variant
    Dim lngIndex As Long, i As Integer, intColNum As Integer

    If sColNumList = "" Then Exit Function

    arColNumList = Split(sColNumList, ",")

    With frm.Controls(sLstBxName)
        For i = LBound(arColNumList) To UBound(arColNumList)
            intColNum = Val(Trim(arColNumList(i)))          'Trim de bo loi khoang trang neu co
            If intColNum > .ColumnCount Then Exit Function  'Neu so thu tu cot khong có trong listbox se bao loi
            For lngIndex = 0 To .ListCount - 1
                .List(lngIndex, intColNum - 1) = (Format(Val(.List(lngIndex, intColNum - 1)), sNumFormat))
            Next
        Next i
    End With
End Function

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Cập nhật: 06/06/2019

Đã cập nhật file mới sử dụng code (dùng mảng) của bạn befaint để tối ưu tốc độ tìm kiếm.

+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Cập nhật: 09/06/2019

Cập nhật thêm file mới sử dụng code (dùng mảng) của bạn HeSanbi rất ngắn gọn và bẫy lỗi khi range dữ liệu cho listbox không có data.


(***PS: tôi vẫn giữa các file phiên bản khác nhau để các tham khảo code các kiểu)

 

[thuyyeu99]

Anh có thấy add nguyên arr vào no lẹ hon add từng item hông, tại sao?.
Số là số còn dấu phân cach la do truoc khi anh add anh chuyen qua string thôi, theo em nghĩ là vậy hihi.

 

[ongke0711]

Anh có thấy add nguyên arr vào no lẹ hon add từng item hông, tại sao?.
Số là số còn dấu phân cach la do truoc khi anh add anh chuyen qua string thôi, theo em nghĩ là vậy hihi.

đúng rồi em, cập nhật nguyên gói một lúc bao giờ cũng nhanh hơn dùng vòng lặp thêm từng item (bên Access thì nó dùng Recordset thay cho Array). Tuỳ vào nguồn dữ liệu đầu vào mà mình chọn kiểu nào tốt nhất cho nó. Còn vụ định dạng số, ý anh nói là cách nó hiển thị trong listbox sau khi đổ xuống từ mảng, nó không còn hiển thị dạng "#,00" hoặc "Standard". Vd: nó hiển thị 60000 chứ không hiển thị 60,000 cho dễ nhìn.

 

[thuyyeu99]

đúng rồi em, cập nhật nguyên gói một lúc bao giờ cũng nhanh hơn dùng vòng lặp thêm từng item (bên Access thì nó dùng Recordset thay cho Array). Tuỳ vào nguồn dữ liệu đầu vào mà mình chọn kiểu nào tốt nhất cho nó. Còn vụ định dạng số, ý anh nói là cách nó hiển thị trong listbox sau khi đổ xuống từ mảng, nó không còn hiển thị dạng "#,00" hoặc "Standard". Vd: nó hiển thị 60000 chứ không hiển thị 60,000 cho dễ nhìn.

Vì trong mãng nó la 60000 chu khong phai 60,000 nếu vậy anh phải format nó thôi

 

[thuyyeu99]

Ah mà lâu lắm rồi em có Dowload được 1 cái Control list rất đẹp bên Diễn đàn VB về em có Desight lại nhúng vào Excel, tốc độ load dữ so với Listbox 9/10 đó anh, giao diện thì rất đẹp, đẹp hơn ListView luôn. mà em mất Soure rồi. anh thử vô đó tìm xem

 

[ongke0711]

Vì trong mãng nó la 60000 chu khong phai 60,000 nếu vậy anh phải format nó thôi

Mới cập nhật thêm cái hàm format kiểu số cho các cột tuỳ chọn trong listbox.
Anh cũng tìm thấy cái class canh lề trái phải cột trong listbox nhưng chạy không nhanh nên không đưa lên đây.
Về cái Listview control thì anh tìm chưa ra.

 

[thuyyeu99]

giỏi quá, anh thử rút gọn nữa thử xem được hông

 

[Hoàng Nhật Phương]

Form tìm kiếm listbox thì diễn đàn cũng có nhiều bài rồi nhưng nó nằm chung trong các bài hỏi của thành viên nên tìm cũng mệt . Vừa làm vừa học nên tôi tạo cái post này cho dễ tìm kiếm và nhờ các anh em giúp cải thiện cái form này cho chạy trơn tru và thuận tiện nhé.
- Form dùng tìm kiếm theo nhiều cột trong listbox. Chỉ cần gõ ký tự chuỗi bất kỳ, nó sẽ tìm trong tất cả các cột để lấy ra dòng có chứa chuỗi.
- Viết dạng hàm để có thể gọi sử dụng lại ở nhiều form.

Điểm chưa làm được:
- Chưa định dạng được dữ liệu hiển thị từng cột trong listbox (dùng mảng gán row source cho listbox). Cụ thể trong demo là cột [Đơn giá]: không có định dạng số (dấu cách phần ngàn .000).
- Chưa tuỳ chọn Sort dữ liệu tự động (theo cột đã chọn) trong listbox sau khi tìm kiếm (có tham khảo mấy hàm bubble sort trên mạng nhưng tích hợp vô).

Bạn nào chỉ cần tìm kiếm dữ liệu thì tôi nghĩ form này đáp ứng yêu cầu.
Các bạn hỗ trợ bổ sung thiết kế giùm nhé. File đính kèm bên dưới.
Cảm ơn.


Code cho Userform:

Option Explicit

Dim oRngLstBx1 As Range

Private Sub txtChuoiTK_Change()
    Dim strTextSearch As String

    strTextSearch = Me.txtChuoiTK.Value
    Call faytLstBxMultiCol(oRngLstBx1, strTextSearch, "lstDanhSachVPP", Me)

End Sub

Private Sub UserForm_Initialize()
    ganSourceListbox
    Me.txtChuoiTK.SetFocus
End Sub


Sub ganSourceListbox()

    Dim sArr() As Variant

    Set oRngLstBx1 = Range(Range("A2"), Range("A2").End(xlDown).End(xlToRight))     'Khai báo cho biesn toàn cuc de su dung cho hàm TK
    ReDim sArr(1 To oRngLstBx1.Rows.Count, 1 To oRngLstBx1.Columns.Count)

    sArr = oRngLstBx1.Value
    Me.lstDanhSachVPP.List = sArr

End Sub

- Hàm faytLstBxMultiCol():

Option Explicit

Function faytLstBxMultiCol(oLstBxRng As Range, strSearchTxt As String, strLstBxName As String, frm As UserForm) As Boolean
'----------------------------------------------------------
'# Hàm tim kiem,loc danh sach listbox theo chuoi tìm kiem.
'# oLstBxRng:       là Range làm Row Source cho Listbox.
'# strSearchTxt:    Chuoi can tim (tu textbox).
'# strLstBxName:    Ten cua listbox control tren userform.
'----------------------------------------------------------

On Error GoTo EH

    Dim sArr() As Variant
    Dim blnFound As Boolean 'bien neu tim thay chuoi can tìm
    Dim i As Long, j As Long, rCount As Long
    Dim oLstBx As Object

    faytLstBxMultiCol = False
    Set oLstBx = frm.Controls(strLstBxName)

    ReDim sArr(1 To oLstBxRng.Columns.Count, 1 To oLstBxRng.Rows.Count)

    For i = 1 To oLstBxRng.Rows.Count
        blnFound = False
        For j = 1 To oLstBxRng.Columns.Count
            If InStr(1, oLstBxRng.Cells(i, j).Value, strSearchTxt, vbTextCompare) > 0 Then  'Tim kiem chuoi tung dong, cot
                blnFound = True     'Tim thay chuoi
                Exit For
            End If
        Next j
        If blnFound Then
            rCount = rCount + 1     'Luu tong so dòng tìm hay chuoi
            For j = 1 To oLstBxRng.Columns.Count
                sArr(j, rCount) = oLstBxRng.Cells(i, j).Value   'Dua tri tim duoc vao mang, luu hang ngang
            Next j
        End If
    Next i

    'Khai bao lai kich thuoc mang theo so dong tim thay chuoi
    If rCount > 0 Then
        ReDim Preserve sArr(1 To j - 1, 1 To rCount)
    Else    'Khong tim thay dòng nào chua chuoi tk
        ReDim Preserve sArr(1 To j - 1, 1 To 1)
    End If

    If UBound(sArr, 2) > 1 Then     'Mang co nhieu gia tri giong chuoi tim kiem
        sArr = Application.WorksheetFunction.Transpose(sArr)
        oLstBx.List = sArr
    Else    'Mang tra ve chinh xác 1 giá tri tim kiem
        oLstBx.Clear
        oLstBx.AddItem
        For i = 1 To UBound(sArr)
            oLstBx.Column(i - 1, 0) = sArr(i, 1)
        Next i
    End If

    faytLstBxMultiCol = True
    Exit Function

EH_Exit:
    faytLstBxMultiCol = False
    Exit Function
EH:
    MsgBox "Loi: " & Err.Number & vbNewLine & "Noi dung loi: " & Err.Description
    Resume EH_Exit

End Function

++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

Bổ sung: (sau thời gian mò mẫm thêm )
- Thêm phần định các cột kiểu số (number) trong listbox với dấu phân cách hàng ngàn.
- Hàm dùng định dạng cột kiểu số trong listbox với tuỳ chọn nhiều cột.
(Đã đính kèm thêm file có định dạng cột)

Mình cũng có sưu tầm được một Class dùng để "canh lề" từng cột trong listbox riêng biệt (hiện nay Listbox chỉ cho phép canh lề một kiểu, áp dụng cho toàn bộ listbox) nhưng khi chạy thấy nó tải dữ liệu lên listbox chậm nên không đưa vô đây.
Giải thuật của các class này là xử lý từng cột -> từng record -> dùng label tạm để lưu nội dung record, thêm dấu cách vào trước, sau hoặc 2 bên để canh phải, trái, giữa rồi lưu lại nội dung vừa sửa vào listbox. Danh sách có 200 dòng mà nó chạy vòng lập cũng mất ~ 2s nên thôi bỏ qua giải pháp này.

Code hàm formatNumColumnLstBx() :

Function formatNumColumnLstBx(sLstBxName As String, sColNumList As String, frm As UserForm, sNumFormat As String)

'----------------------------------------------------------------
'# Muc dích: dùng dinh dang các cot kieu Number trong listbox và dùng trong truong hop dùng Mang (Array) gan du lieu cho LstBox.
'# Tham so:
'#   - sColNumList: danh sách các cot can dinh dang So, cách nhau dau phay ','. Vd: "4,5,6".
'#   - sNumFormat:  kieu dinh dang so. Vd: "#,##0": "#,##0.00" hoac "$#,##0.00"
'----------------------------------------------------------------

    Dim arColNumList As Variant
    Dim lngIndex As Long, i As Integer, intColNum As Integer
 
    If sColNumList = "" Then Exit Function
 
    arColNumList = Split(sColNumList, ",")

    With frm.Controls(sLstBxName)
        For i = LBound(arColNumList) To UBound(arColNumList)
            intColNum = Val(Trim(arColNumList(i)))          'Trim de bo loi khoang trang neu co
            If intColNum > .ColumnCount Then Exit Function  'Neu so thu tu cot khong có trong listbox se bao loi
            For lngIndex = 0 To .ListCount - 1
                .List(lngIndex, intColNum - 1) = (Format(Val(.List(lngIndex, intColNum - 1)), sNumFormat))
            Next
        Next i
    End With
End Function

View attachment 218600

Cảm ơn bạn nhiều,
Ứng dụng này rất thiết thực trong thực tế.
Bạn có thể mở rộng thêm tính năng nhập liệu nữa được không ạ (nghĩa là khi kích vào dòng nào sẽ nhập liệu dòng đó xuống bảng tính)?

 

[SA_DQ]

Ứng dụng này rất thiết thực trong thực tế.
Bạn có thể mở rộng thêm tính năng nhập liệu nữa được không ạ (nghĩa là khi kích vào dòng nào sẽ nhập liệu dòng đó xuống bảng tính)?

Nếu không thông qua 1 bước đệm, thì chả mấy chốc CSDL thành đống rác, không hơn không kém!

 

[ongke0711]

Cảm ơn bạn nhiều,
Ứng dụng này rất thiết thực trong thực tế.
Bạn có thể mở rộng thêm tính năng nhập liệu nữa được không ạ (nghĩa là khi kích vào dòng nào sẽ nhập liệu dòng đó xuống bảng tính)?

Bạn nên cho ví dụ 1 trường hợp cụ thể, thực tế gần sát với thao tác xử lý với form tìm kiếm này để dễ hình dung và có cái nhìn tổng thể mới dễ xử lý hơn vì nó còn liên quan nhiều thứ bẫy lỗi dữ liệu, qui trình, luồng xử lý thao tác trên Form ...
Chẳng hạn như tôi thường dùng Form này như 1 form danh sách (ds khách hàng, ds phiếu nhập, xuất ...), sau khi tìm kiếm sẽ click chọn record tìm thấy -> mở form chi tiết tương ứng record đó để chỉnh sửa.
Nếu có file dữ liệu mẫu thực tế nào đó tốt, khỏi mất công tự tạo để test

 

[thuyyeu99]

Hông biết mình tìm trên range hay trên mảng cái nào lẹ hơn vậy anh ??

 

[ongke0711]

Hông biết mình tìm trên range hay trên mảng cái nào lẹ hơn vậy anh ??

Theo như thông tin anh đã đọc trước đây thì tìm kiếm trên mảng nhanh hơn nhiều so với tìm trên range.
Có một kỹ thuật được khuyên là nếu giảm được tương tác giữa Worksheet với VBA thì nên giảm để tăng hiệu quả xử lý. Do đó việc load toàn bộ range lên mảng, ngắt kết nối với worksheet, thực hiện tính toán, xử lý trên mảng xong rồi gán một cục xuống worksheet sẽ nhanh hơn rất nhiều so với việc tương tác liên tục giữa worksheet (cell), biến và VBA.
Còn muốn thực tế thì phải chịu khó viết code test thử với số dòng tương đối lớn để xem như thế nào.
Các anh em có kinh nghiệm gì khác thì chia sẻ để học hỏi thêm nhé.

Link tham khảo: https://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/

 

[thuyyeu99]

Theo như thông tin anh đã đọc trước đây thì tìm kiếm trên mảng nhanh hơn nhiều so với tìm trên range.
Có một kỹ thuật được khuyên là nếu giảm được tương tác giữa Worksheet với VBA thì nên giảm để tăng hiệu quả xử lý. Do đó việc load toàn bộ range lên mảng, ngắt kết nối với worksheet, thực hiện tính toán, xử lý trên mảng xong rồi gán một cục xuống worksheet sẽ nhanh hơn rất nhiều so với việc tương tác liên tục giữa worksheet (cell), biến và VBA.
Còn muốn thực tế thì phải chịu khó viết code test thử với số dòng tương đối lớn để xem như thế nào.
Các anh em có kinh nghiệm gì khác thì chia sẻ để học hỏi thêm nhé.

Link tham khảo: https://fastexcel.wordpress.com/2011/10/26/match-vs-find-vs-variant-array-vba-performance-shootout/

Vậy sao anh không tìm thẳng trên arr toàn cục và check column number format luôn mà làm chi cho nó ngoằn ngoèo vậy. Cái này em nghĩ dữ liệu nhiều nó chậm áh

 

[ongke0711]

Vậy sao anh không tìm thẳng trên arr toàn cục và check column number format luôn mà làm chi cho nó ngoằn ngoèo vậy. Cái này em nghĩ dữ liệu nhiều nó chậm áh

Trình Array chưa tới nên a đang ngâm cứu vụ format trong mảng... . Nếu đã làm qua em demo cho anh học hỏi nhé (cho nhanh).
Nếu viết được cái hàm định dạng luôn trong mảng sẽ hỗ trợ nhiều vì nhiều trường hợp đưa dữ liệu lên mảng xong đổ xuống mất định dạng. vd: số điện thoại dạng text có 1 số '0' đầu sau khi đưa lên mảng gán xuống nó mất số '0'.

 

[Kiều Mạnh]

Trình Array chưa tới nên a đang ngâm cứu vụ format trong mảng... . Nếu đã làm qua em demo cho anh học hỏi nhé (cho nhanh).
Nếu viết được cái hàm định dạng luôn trong mảng sẽ hỗ trợ nhiều vì nhiều trường hợp đưa dữ liệu lên mảng xong đổ xuống mất định dạng. vd: số điện thoại dạng text có 1 số '0' đầu sau khi đưa lên mảng gán xuống nó mất số '0'.

Mạnh lâu nay bận quá chỉ ngó qua chút ko có thời gian mò code
Bạn tham khảo link sau bài #15 xem sao nha... thử gán cái mảng đó vào bộ nhớ xong gán lại Sheet xem !!!

Cách lấy dữ liệu từ Clipboad vào mảng bằng VBA

Gửi thành viên trong diễn đàn! Mình đang có vấn đề như trên tiêu đề có bác nào biết thì trợ giúp mình với. Việc copy vào clipboad được copy từ Excel thôi.

www.giaiphapexcel.com

 

[ongke0711]

Mạnh lâu nay bận quá chỉ ngó qua chút ko có thời gian mò code
Bạn tham khảo link sau bài #15 xem sao nha... thử gán cái mảng đó vào bộ nhớ xong gán lại Sheet xem !!!

Cách lấy dữ liệu từ Clipboad vào mảng bằng VBA

Gửi thành viên trong diễn đàn! Mình đang có vấn đề như trên tiêu đề có bác nào biết thì trợ giúp mình với. Việc copy vào clipboad được copy từ Excel thôi.

www.giaiphapexcel.com

Bạn mạnh chắc thích nhạc Sơn Tùng bài "Em đi xa quá...".
Tôi muốn học hỏi cách viết hàm hoặc chèn code để tuỳ chọn định dạng cột nào muốn trong mảng trước khi đổ dữ liệu xuống Excel sheet để cái kỹ thuật tìm kiếm này chạy tốt hơn.

 

[befaint]

số điện thoại dạng text có 1 số '0' đầu sau khi đưa lên mảng gán xuống nó mất số '0'.

Anh thêm dấu nháy vào là được mà.

"'" & so

 

[Kiều Mạnh]

Bạn mạnh chắc thích nhạc Sơn Tùng bài "Em đi xa quá...".
Tôi muốn học hỏi cách viết hàm hoặc chèn code để tuỳ chọn định dạng cột nào muốn trong mảng trước khi đổ dữ liệu xuống Excel sheet để cái kỹ thuật tìm kiếm này chạy tốt hơn.

Mạnh thích cái Hàm này : faytLstBxMultiCol

Nếu có thời gian mạnh sẻ dựa trên code đó viết lại:

1/ bỏ hàm ( Transpose ) sArr = Application.WorksheetFunction.Transpose(sArr)
sẻ viết thêm 1 hàm chuyển mảng vô đó nó sẻ cho tốc độ nhanh hơn Hàm Transpose một chút đấy

2/ sẻ viết lại 1 hàm chung nhất có thể xài trên Cells hay textbox trên Sheet khi ta gõ vào đó

3/ khi lọc xong kết quả có thể gán xuống sheet hay ở đâu đó do mình gán
.... ý tưởng vậy mà cũng chưa biết khi nào rảnh mà quậy nữa

 

[befaint]

demo cho anh

Anh chạy thử xem nhé. Em chạy thử 20 nghìn dòng thấy sự khác biệt rõ ràng..

Hàm tìm trên array

Option Explicit

Public Function find_range_multiCol(ByVal source_range As Range, ByVal string_find As String)
    ''
    ' source_range: vung du lieu goc    '
    ' string_find: chuoi can tim        '
    ' ket qua tra ve mang cac phan tu tim duoc theo string_find.    '
    ''
    Dim arr() As Variant, max_row As Long, max_col As Long, i As Long, j As Long, k As Long
    Dim result() As Variant, item_arr As Variant, kk As Long
    If source_range.Count = 1 Then
        find_range_multiCol = Array(source_range.Value2)
        Exit Function    '// khong xet source_range chi co 1 cell'
    End If
    arr = source_range.Value2   '// chep range vao mang arr'
    max_row = UBound(arr, 1)
    max_col = UBound(arr, 2)
    ReDim result(1 To max_col, 1 To max_row)    '// khai bao kich thuoc mang result, xoay 90 do so voi mang arr'
    string_find = VBA.UCase(string_find)
    If Len(string_find) > 0 Then
        string_find = "*" & string_find & "*"
        For i = 1 To max_row
            For k = 1 To max_col
                item_arr = VBA.UCase(arr(i, k))
                If item_arr Like string_find Then 'neu tim thay'
                    j = j + 1
                    For kk = 1 To max_col
                        result(kk, j) = arr(i, kk)
                    Next kk
                    Exit For    'thoat tim '
                End If
            Next k
        Next i
        If j Then
            ReDim Preserve result(1 To max_col, 1 To j)
            ' xoay mang result'
            find_range_multiCol = transpose_array(result)
        Else
            find_range_multiCol = Array("")
        End If
    Else
        find_range_multiCol = arr
    End If
End Function

Public Function transpose_array(ByVal source_array As Variant)
    ' source_array: mang 2 chieu '
    ' xoay mang source_array 90 do '
    Dim arr As Variant, max_row As Long, max_col As Long, result(), i As Long, j As Long
    arr = source_array
    max_row = UBound(arr, 1)
    max_col = UBound(arr, 2)
    ReDim result(1 To max_col, 1 To max_row)
    For i = 1 To max_row
        For j = 1 To max_col
            result(j, i) = arr(i, j)
        Next j
    Next i
    transpose_array = result
End Function

Code cho sự kiện tìm

Private Sub txtChuoiTK_Change()
    Dim strTextSearch As String
    strTextSearch = Me.txtChuoiTK.Value
    'Call faytLstBxMultiCol(oRngLstBx1, strTextSearch, "lstDanhSachVPP", frmSearch)

    Me.lstDanhSachVPP.List = find_range_multiCol(oRngLstBx1, strTextSearch)
End Sub

 

[befaint]

định dạng luôn trong mảng

Anh xem thử nhé..

Public Function find_range_multiCol(ByVal source_range As Range, ByVal string_find As String, _
                                    Optional ByVal list_col_format_number As String = "0", _
                                    Optional ByVal type_format As String = "#,##0")
    ''
    ' source_range: vung du lieu goc    '
    ' string_find: chuoi can tim        '
    ' list_col_format_number: danh sach cac cot can dinh dang "2,3,4" '
    ' type_format: kieu dinh dang, mac dinh "#,##0" '
    ' ket qua tra ve mang cac phan tu tim duoc theo string_find.    '
    ''
    Dim arr() As Variant, max_row As Long, max_col As Long, i As Long, j As Long, k As Long
    Dim result() As Variant, item_arr As Variant, kk As Long, flag_format As Boolean, list_col, icol
    If source_range.Count = 1 Then
        find_range_multiCol = Array(source_range.Value2)
        Exit Function    '// khong xet source_range chi co 1 cell'
    End If
    arr = source_range.Value2   '// chep range vao mang arr'
    max_row = UBound(arr, 1)
    max_col = UBound(arr, 2)
    ReDim result(1 To max_col, 1 To max_row)    '// khai bao kich thuoc mang result, xoay 90 do so voi mang arr'
    string_find = VBA.UCase(string_find)
    If list_col_format_number <> "0" Then
        flag_format = True
        list_col_format_number = Replace(list_col_format_number, " ", "")
        list_col = Split(list_col_format_number, ",")
    End If
    If Len(string_find) > 0 Then
        string_find = "*" & string_find & "*"
        For i = 1 To max_row
            For k = 1 To max_col
                item_arr = VBA.UCase(arr(i, k))
                If item_arr Like string_find Then 'neu tim thay'
                    j = j + 1
                    For kk = 1 To max_col
                        result(kk, j) = arr(i, kk)
                        If flag_format = True Then  ' ding dang '
                            For Each icol In list_col
                                If icol >= 1 And icol <= max_col Then
                                    result(icol, j) = Format(Val(arr(i, icol)), type_format)
                                End If
                            Next icol
                        End If
                    Next kk
                    Exit For    'thoat tim '
                End If
            Next k
        Next i
        If j Then
            ReDim Preserve result(1 To max_col, 1 To j)
            ' xoay mang result'
            find_range_multiCol = transpose_array(result)
        Else
            find_range_multiCol = Array("")
        End If
    Else
        find_range_multiCol = arr
    End If
End Function

Private Sub txtChuoiTK_Change()
    Dim strTextSearch As String
    strTextSearch = Me.txtChuoiTK.Value
    'Call faytLstBxMultiCol(oRngLstBx1, strTextSearch, "lstDanhSachVPP", frmSearch)

    Me.lstDanhSachVPP.List = find_range_multiCol(oRngLstBx1, strTextSearch, "5")
End Sub