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

Liên hệ QC

ongke0711

Thành viên gắn bó
Tham gia
7/9/06
Bài viết
1,955
Được thích
2,538
Giới tính
Nam
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:

Mã:
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():

Mã:
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() :

Mã:
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)


218600
 

File đính kèm

  • TimKiemListBox_nhieuCot.xlsm
    50.3 KB · Đọc: 427
  • TimKiemListBox_nhieuCot_FormatColumn.xlsm
    56.2 KB · Đọc: 333
  • TimKiemListBox_nhieuCot(dungArray).xlsm
    49.5 KB · Đọc: 302
  • TimKiemListBox_nhieuCot(dungArray)_HeSanbi.xlsm
    44.4 KB · Đọc: 467
Lần chỉnh sửa cuối:
Upvote 0
anh @ongke0711 wa siêu cao thủ. em thành viên mới cũng đang có cùng thắc như bạn iloveit anh Ongke giúp cho em code này đc không ah

Bạn nói tôi nhột quá..:p

Lưu xuống sheet thì đơn giản rồi.

Mã:
Private Sub lstDanhSachVPP_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    '// Luu xuong Sheet
    Dim i As Long, lr As Long
    lr = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    For i = 1 To Me.lstDanhSachVPP.ColumnCount - 1  'bo cot Stt -cot (0)
        Worksheets("Sheet1").Range("A" & lr).Offset(1, i - 1) = Me.lstDanhSachVPP.List(Me.lstDanhSachVPP.ListIndex, i)
    Next i
    MsgBox "Da luu"
    
End Sub

Lấy lại file của bài #44, thêm cái thủ tục ở trên vô Userform.
 
Upvote 0
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:

Mã:
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():

Mã:
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() :

Mã:
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)


View attachment 218600
Chào các anh/chị trên diễn đàn.
Xin được các anh/chị giúp em để có thể:
1/ Copy Nội dung trực tiếp trong ô nào đó ở giao diện Form (khi chọn ô đó)
2/ Đi tới ô chứa nội dung trong excel khi Click đúp chuột trái vào ô chứa nội dung từ giao diện Form.

Em xin chân thành cảm ơn!
Giup.png
 

File đính kèm

  • Giup.xlsm
    108.5 KB · Đọc: 29
Upvote 0
Anh ongke0711 và thầy befaint Cho em xin file tìm kiếm có thể Checked chọn tìm kiếm theo cột như vậy với ạ?

File trong hình là Form của MS Access. Các checkbox dùng chọn cột dữ liệu nào được dùng để tìm kiếm theo từ khoá. Trong chủ để này tôi và các bạn đã thiết kế mặc định tìm kiếm dữ liệu từ "tất cả" các cột trong bảng rồi, không cần giới hạn cột tìm kiếm làm chi.
 
Upvote 0
File trong hình là Form của MS Access. Các checkbox dùng chọn cột dữ liệu nào được dùng để tìm kiếm theo từ khoá. Trong chủ để này tôi và các bạn đã thiết kế mặc định tìm kiếm dữ liệu từ "tất cả" các cột trong bảng rồi, không cần giới hạn cột tìm kiếm làm chi.
Vâng, xin cảm ơn anh!
 
Upvote 0
1/ Copy Nội dung trực tiếp trong ô nào đó ở giao diện Form (khi chọn ô đó)
2/ Đi tới ô chứa nội dung trong excel khi Click đúp chuột trái vào ô chứa nội dung từ giao diện Form.

1. Copy nội dung cũng có nhiều cách. Khi click đôi vào Textbox thì gán giá trị của Textbox đó vào một biến nào đó, khi cần thì lấy biến đó ra sử dụng. Còn muốn copy vào Clipboard thì code cho cái API này cũng có đầy trên mạng. Cái quan trọng là bạn chọn sự kiện nào để kích hoạt gọi hàm copy thôi. Hàm dùng API copy vào Clipboard tôi để bên dưới.

2. Tác vụ này bạn chỉ cần tách ra 2 công việc:
- Khi click đúp vào nội dung nào đó trên Form là lấy ngay cái thông tin từ khoá chính của dòng dữ liệu đó. Cái khoá chính này giúp phân biệt giữa các dòng dữ liệu với nhau và tất nhiên phải không trùng. Cụ thể trong Form của bạn là cột [STT].
- Sau khi có từ khoá chính rồi thì dùng phương thức Find của Excel tìm ra dòng chứa khoá chính đó rồi di chuyển thôi.

Mã:
Private Sub lstDanhSachVPP_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Dim SearchRange As Range
    Dim sCrit As String, rowNum As Long

    sCrit = Me.lstDanhSachVPP.Column(0)     'STT
    Set SearchRange = Sheets("Excel").Range("A1", Range("A65536").End(xlUp))
    rowNum = SearchRange.Find(sCrit, LookIn:=xlValues, lookat:=xlWhole).Row
    
    SearchRange.Cells(rowNum, 2).Select

End Sub




Mã:
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "User32" () As LongPtr
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
#Else
    Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
    Private Declare Function CloseClipboard Lib "user32.dll" () As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
    Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
#End If

Public Sub SetClipboard(sUniText As String)

    #If VBA7 Then
        Dim iStrPtr As LongPtr
        Dim iLock As LongPtr
    #Else
        Dim iStrPtr As Long
        Dim iLock As Long
    #End If

    Dim iLen As Long

    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD

    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE + GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard
End Sub

Public Function GetClipboard() As String
    #If VBA7 Then
        Dim iStrPtr As LongPtr
        Dim iLock As LongPtr
    #Else
        Dim iStrPtr As Long
        Dim iLock As Long
    #End If
    Dim iLen As Long
    Dim sUniText As String

    Const CF_UNICODETEXT As Long = 13&

    OpenClipboard 0&

    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If

    CloseClipboard
End Function


'// Test hàm -----------------------------------------
Sub CopyToClipBoard()
    SetClipboard Sheets("Excel").Range("B2").Value
End Sub

Sub paste()
    Sheets("Excel").Range("A14").Value = GetClipboard
End Sub
 
Upvote 0
1. Copy nội dung cũng có nhiều cách. Khi click đôi vào Textbox thì gán giá trị của Textbox đó vào một biến nào đó, khi cần thì lấy biến đó ra sử dụng. Còn muốn copy vào Clipboard thì code cho cái API này cũng có đầy trên mạng. Cái quan trọng là bạn chọn sự kiện nào để kích hoạt gọi hàm copy thôi. Hàm dùng API copy vào Clipboard tôi để bên dưới.

2. Tác vụ này bạn chỉ cần tách ra 2 công việc:
- Khi click đúp vào nội dung nào đó trên Form là lấy ngay cái thông tin từ khoá chính của dòng dữ liệu đó. Cái khoá chính này giúp phân biệt giữa các dòng dữ liệu với nhau và tất nhiên phải không trùng. Cụ thể trong Form của bạn là cột [STT].
- Sau khi có từ khoá chính rồi thì dùng phương thức Find của Excel tìm ra dòng chứa khoá chính đó rồi di chuyển thôi.

Mã:
Private Sub lstDanhSachVPP_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    Dim SearchRange As Range
    Dim sCrit As String, rowNum As Long

    sCrit = Me.lstDanhSachVPP.Column(0)     'STT
    Set SearchRange = Sheets("Excel").Range("A1", Range("A65536").End(xlUp))
    rowNum = SearchRange.Find(sCrit, LookIn:=xlValues, lookat:=xlWhole).Row
 
    SearchRange.Cells(rowNum, 2).Select

End Sub




Mã:
Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function OpenClipboard Lib "User32" (ByVal hWnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function EmptyClipboard Lib "User32" () As LongPtr
    Private Declare PtrSafe Function CloseClipboard Lib "User32" () As LongPtr
    Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetClipboardData Lib "User32" (ByVal wFormat As LongPtr) As LongPtr
    Private Declare PtrSafe Function SetClipboardData Lib "User32" (ByVal wFormat As LongPtr, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongPtr
    Private Declare PtrSafe Function GlobalLock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function GlobalSize Lib "kernel32" (ByVal hMem As LongPtr) As Long
    Private Declare PtrSafe Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongPtr
#Else
    Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
    Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
    Private Declare Function CloseClipboard Lib "user32.dll" () As Long
    Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
    Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
    Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
    Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
    Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
    Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
    Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long
#End If

Public Sub SetClipboard(sUniText As String)

    #If VBA7 Then
        Dim iStrPtr As LongPtr
        Dim iLock As LongPtr
    #Else
        Dim iStrPtr As Long
        Dim iLock As Long
    #End If

    Dim iLen As Long

    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD

    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE + GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard
End Sub

Public Function GetClipboard() As String
    #If VBA7 Then
        Dim iStrPtr As LongPtr
        Dim iLock As LongPtr
    #Else
        Dim iStrPtr As Long
        Dim iLock As Long
    #End If
    Dim iLen As Long
    Dim sUniText As String

    Const CF_UNICODETEXT As Long = 13&

    OpenClipboard 0&

    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If

    CloseClipboard
End Function


'// Test hàm -----------------------------------------
Sub CopyToClipBoard()
    SetClipboard Sheets("Excel").Range("B2").Value
End Sub

Sub paste()
    Sheets("Excel").Range("A14").Value = GetClipboard
End Sub
Dạ em cảm ơn anh, copy code trên vào thay thế code trong Form à anh?
Nhờ anh hướng dẫn em rõ hơn chút ạ?
 
Lần chỉnh sửa cuối:
Upvote 0
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:

Mã:
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():

Mã:
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() :

Mã:
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)


View attachment 218600
Add cho em hỏi: tìm kiếm trong Form listbox nhưng khi tìm được trong giao diện Form nhưng không thể tác động được vào giao diện đó:
Nghĩa là chỉ xem trên giao diện đó, sau đó lại tắt giao diện đó đi, muốn thao tác hoặc chỉnh sửa gì lại phải vào trực tiếp excel để thao tác.
Trong trường hợp muốn tìm 10 hàng chả hạn: tìm được trong Form listbox. Nhưng sau đó vào excel làm sao để tới được 10 hàng đã tìm trong giao diện đó: phải ghi ra giấy 10 hàng đã tìm được trong Form listbox sau đó tìm lại bằng số thứ tự trực tiếp trên exel.
Rất mong ad giúp em vấn đề em nêu trên.
 
Upvote 0
Add cho em hỏi: tìm kiếm trong Form listbox nhưng khi tìm được trong giao diện Form nhưng không thể tác động được vào giao diện đó:
Nghĩa là chỉ xem trên giao diện đó, sau đó lại tắt giao diện đó đi, muốn thao tác hoặc chỉnh sửa gì lại phải vào trực tiếp excel để thao tác.
Trong trường hợp muốn tìm 10 hàng chả hạn: tìm được trong Form listbox. Nhưng sau đó vào excel làm sao để tới được 10 hàng đã tìm trong giao diện đó: phải ghi ra giấy 10 hàng đã tìm được trong Form listbox sau đó tìm lại bằng số thứ tự trực tiếp trên exel.
Rất mong ad giúp em vấn đề em nêu trên.

Vụ này tuỳ thuộc vào khả năng thiết kế ứng dụng của bạn. Bạn phải định hướng thiết kế, áp dụng bộ code tìm kiếm trong demo ở trên vào qui trình xử lý nào, sau khi tìm kiếm sẽ đến các tác vụ gì, xử lý ra sao v.v...Cái Form tôi làm mẫu ở trên đâu phải là cái Form chết mà tuỳ mỗi người ứng dụng vào việc thiết kế lập trình của họ.
Có người thì muốn sau khi tìm thấy dòng dữ liệu thì muốn nó hiển thị lên các Textbox trên chính cái Form tìm kiếm để có thể chỉnh sửa rồi lưu xuống sheet. Hoặc khi click đúp chọn nó thì sẽ mở cái Form khác có chứa dữ liệu vừa chọn để thực hiện các thao tác gì đó.
Có người muốn tìm kiếm dữ liệu trong khoảng thời gian nào đó để báo cáo, in ấn, để xoá nếu nhập liệu sai v.v..
Nói chung bạn phải biết tích hợp các mẫu code nhỏ thực hiện một tác vụ nào đó vào một qui trình xử lý, tác vụ lớn của bạn.

(Hình minh hoạ áp dụng code tìm kiếm vào Form nhập liệu. Form của Ms Access. Xin đừng xin file :) )

Screen Shot 2021-06-30 at 20.59.05.png
 
Lần chỉnh sửa cuối:
Upvote 0
Vụ này tuỳ thuộc vào khả năng thiết kế ứng dụng của bạn. Bạn phải định hướng thiết kế, áp dụng bộ code tìm kiếm trong demo ở trên vào qui trình xử lý nào, sau khi tìm kiếm sẽ đến các tác vụ gì, xử lý ra sao v.v...Cái Form tôi làm mẫu ở trên đâu phải là cái Form chết mà tuỳ mỗi người ứng dụng vào việc thiết kế lập trình của họ.
Có người thì muốn sau khi tìm thấy dòng dữ liệu thì muốn nó hiển thị lên các Textbox trên chính cái Form tìm kiếm để có thể chỉnh sửa rồi lưu xuống sheet. Hoặc khi click đúp chọn nó thì sẽ mở cái Form khác có chứa dữ liệu vừa chọn để thực hiện các thao tác gì đó.
Có người muốn tìm kiếm dữ liệu trong khoảng thời gian nào đó để báo cáo, in ấn, để xoá nếu nhập liệu sai v.v..
Nói chung bạn phải biết tích hợp các mẫu code nhỏ thực hiện một tác vụ nào đó vào một qui trình xử lý, tác vụ lớn của bạn.

View attachment 261571
Em chưa biết về code.
Nếu có thời gian xin được anh giúp ạ!
 
Upvote 0
Code các anh viết thật tuyệt vời. Áp dụng và học hỏi được rất nhiều
Nhờ anh chị hướng dẫn chỗ này giúp em với ạ. Nếu để các tuỳ chọn trong Listbox như sau
1. Liststyle = 1-frmListstyleOption
2. MultiSelect
Khi tìm kiếm thì Listbox có sự co lại điều chỉnh kích thước của listbox rất xấu khi dùng trên form. Nhờ các anh chị hỗ trợ giúp chỗ này ạ

Hình 1: Tuỳ chọn listbox
1658813323330.png
Hình 2: Khi Load Form
1658813501026.png
Hình 3: Khi tìm kiếm
1658813481850.png
 
Upvote 0
Code các anh viết thật tuyệt vời. Áp dụng và học hỏi được rất nhiều
Nhờ anh chị hướng dẫn chỗ này giúp em với ạ. Nếu để các tuỳ chọn trong Listbox như sau
1. Liststyle = 1-frmListstyleOption
2. MultiSelect
Khi tìm kiếm thì Listbox có sự co lại điều chỉnh kích thước của listbox rất xấu khi dùng trên form. Nhờ các anh chị hỗ trợ giúp chỗ này ạ

Hình 1: Tuỳ chọn listbox
View attachment 279279
Hình 2: Khi Load Form
View attachment 279281
Hình 3: Khi tìm kiếm
View attachment 279280
Để ListBox không tự điều chỉnh kích thước (chủ yếu là chiều cao) thì nên chọn mục IntergralHeight=False nhé bạn. Nhưng điều này sẽ dẫn đến hàng cuối cùng bị mất một phần hoặc toàn bộ, vì thế sau khi lọc hay điều chỉnh list, ta add thêm 1 dòng rỗng nữa.
VD: ListBox1.AddItem Empty, ListBox1.ListCount
 
Upvote 0
Để ListBox không tự điều chỉnh kích thước (chủ yếu là chiều cao) thì nên chọn mục IntergralHeight=False nhé bạn. Nhưng điều này sẽ dẫn đến hàng cuối cùng bị mất một phần hoặc toàn bộ, vì thế sau khi lọc hay điều chỉnh list, ta add thêm 1 dòng rỗng nữa.
VD: ListBox1.AddItem Empty, ListBox1.ListCount
Dạ em thêm dòng trống như anh hướng dẫn vẫn không được anh
1658820499655.png

1658820673115.png
 
Lần chỉnh sửa cuối:
Upvote 0
Để ListBox không tự điều chỉnh kích thước (chủ yếu là chiều cao) thì nên chọn mục IntergralHeight=False nhé bạn.

Anh có nhầm gì không? Theo hình thớt gửi thì listbox bị thu hẹp chiều ngang cơ mà.

Thớt thấy hay nhưng không hiểu bản chất để vận dụng, thản nhiên kết luận "Listbox có sự co lại điều chỉnh kích thước".
 
Upvote 0
Anh có nhầm gì không? Theo hình thớt gửi thì listbox bị thu hẹp chiều ngang cơ mà.

Thớt thấy hay nhưng không hiểu bản chất để vận dụng, thản nhiên kết luận "Listbox có sự co lại điều chỉnh kích thước".
Không biết file đó viết code thế nào, có điều chỉnh độ rộng của cột hay không nên mình không can thiệp được, nhưng thông thường nó sẽ tự điều chỉnh chiều cao của ListBox.
 
Upvote 0
Web KT
Back
Top Bottom