Sửa code tìm kiếm có chứa dữ liệu

[sonchuot90]

Em xin chào anh chị trong nhóm, em có code mong anh chị sửa giúp em, khi tìm chỉ có 1 giá trị duy nhất thì code lại cho ra 1 loạt các hàng dưới giống hệt nhau, em chỉ muốn hiện thị ra 1 lần thôi, còn trường hợp 2 là khi không còn giá trị thị chỗ N/A kia ra khoảng trắng ạ. Vậy mong anh chị trong diễn đàn sửa code giúp em với ạ, Em cám ơn

Bài đã được tự động gộp: 18/11/22

Option Explicit
Function FindInArray(str As Variant, sArr As Variant) As Variant
On Error GoTo Thoat
If IsObject(str) Then
If str.Columns.Count = 1 And str.Rows.Count = 1 Then
str = str.Value2
Else
Exit Function
End If
End If
str = LCase(CStr(str))
If IsObject(sArr) Then
If sArr.Count > 1 Then sArr = sArr.Value2
End If
If IsEmpty(sArr) Then Exit Function
If str = vbNullString Then
FindInArray = sArr
Exit Function
Else
Dim DK As Boolean, i As Long, j As Long, k As Byte, tmp() As Long, tmpArr As Variant
ReDim tmpArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2)) As Byte

tmpArr = sArr
For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
For k = 1 To UBound(tmpArr, 2)
DK = (LCase(CStr(tmpArr(i, k))) Like "*" & str & "*")
If DK Then
j = j + 1
If j = 1 Then
ReDim tmp(1 To 1) As Long
Else
ReDim Preserve tmp(1 To j) As Long
End If
tmp(j) = i
Exit For
End If
Next
Next
If j > 0 Then
Dim Arr As Variant, id As Long
ReDim Arr(1 To j, 1 To UBound(tmpArr, 2))
For i = 1 To j
id = tmp(i)
For k = 1 To UBound(tmpArr, 2)
Arr(i, k) = tmpArr(id, k)
Next
Next
FindInArray = Arr
'FindInArray = arr
Exit Function
End If
End If
Exit Function
Thoat:
Exit Function
End Function

 

[snow25]

Em xin chào anh chị trong nhóm, em có code mong anh chị sửa giúp em, khi tìm chỉ có 1 giá trị duy nhất thì code lại cho ra 1 loạt các hàng dưới giống hệt nhau, em chỉ muốn hiện thị ra 1 lần thôi, còn trường hợp 2 là khi không còn giá trị thị chỗ N/A kia ra khoảng trắng ạ. Vậy mong anh chị trong diễn đàn sửa code giúp em với ạ, Em cám ơn View attachment 283554

Bài đã được tự động gộp: 18/11/22

Option Explicit
Function FindInArray(str As Variant, sArr As Variant) As Variant
On Error GoTo Thoat
If IsObject(str) Then
If str.Columns.Count = 1 And str.Rows.Count = 1 Then
str = str.Value2
Else
Exit Function
End If
End If
str = LCase(CStr(str))
If IsObject(sArr) Then
If sArr.Count > 1 Then sArr = sArr.Value2
End If
If IsEmpty(sArr) Then Exit Function
If str = vbNullString Then
FindInArray = sArr
Exit Function
Else
Dim DK As Boolean, i As Long, j As Long, k As Byte, tmp() As Long, tmpArr As Variant
ReDim tmpArr(1 To UBound(sArr, 1), 1 To UBound(sArr, 2)) As Byte

tmpArr = sArr
For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
For k = 1 To UBound(tmpArr, 2)
DK = (LCase(CStr(tmpArr(i, k))) Like "*" & str & "*")
If DK Then
j = j + 1
If j = 1 Then
ReDim tmp(1 To 1) As Long
Else
ReDim Preserve tmp(1 To j) As Long
End If
tmp(j) = i
Exit For
End If
Next
Next
If j > 0 Then
Dim Arr As Variant, id As Long
ReDim Arr(1 To j, 1 To UBound(tmpArr, 2))
For i = 1 To j
id = tmp(i)
For k = 1 To UBound(tmpArr, 2)
Arr(i, k) = tmpArr(id, k)
Next
Next
FindInArray = Arr
'FindInArray = arr
Exit Function
End If
End If
Exit Function
Thoat:
Exit Function
End Function

Cái thứ nhất dùng dictionary trường hợp 2 khai báo biến arr rộng thêm chút nữa.

 

[sonchuot90]

Cái thứ nhất dùng dictionary trường hợp 2 khai báo biến arr rộng thêm chút nữa.

Code trên em copy trên mạng. Anh có thể sửa giúp em được không? Em cám ơn anh ạ

 

[Hoàng Tuấn 868]

Đoán là viết code mới sẽ nhanh hơn sửa.

 

[snow25]

Code trên em copy trên mạng. Anh có thể sửa giúp em được không? Em cám ơn anh ạ

Thử cái này chưa bẫy lỗi.

Function laygiatri(ByVal dk As String, ByVal mang As Range) As Variant
    Dim dic As Object, i As Long, arr, kq() As String, a As Long
    Set dic = CreateObject("scripting.dictionary")
    arr = mang.Value
    ReDim kq(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If InStr(arr(i, 1), dk) Then
            If Not dic.exists(arr(i, 1)) Then
                a = a + 1
                kq(a, 1) = arr(i, 1)
                dic.Add arr(i, 1), ""
            End If
        End If
    Next i
    Set dic = Nothing
    laygiatri = kq
End Function
=laygiatri(E2,A2:A15)

 

[sonchuot90]

Thử cái này chưa bẫy lỗi.

Function laygiatri(ByVal dk As String, ByVal mang As Range) As Variant
    Dim dic As Object, i As Long, arr, kq() As String, a As Long
    Set dic = CreateObject("scripting.dictionary")
    arr = mang.Value
    ReDim kq(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If InStr(arr(i, 1), dk) Then
            If Not dic.exists(arr(i, 1)) Then
                a = a + 1
                kq(a, 1) = arr(i, 1)
                dic.Add arr(i, 1), ""
            End If
        End If
    Next i
    Set dic = Nothing
    laygiatri = kq
End Function
=laygiatri(E2,A2:A15)

Dạ vâng. Em cám ơn ạ

 

[sonchuot90]

Thử cái này chưa bẫy lỗi.

Function laygiatri(ByVal dk As String, ByVal mang As Range) As Variant
    Dim dic As Object, i As Long, arr, kq() As String, a As Long
    Set dic = CreateObject("scripting.dictionary")
    arr = mang.Value
    ReDim kq(1 To UBound(arr), 1 To 1)
    For i = 1 To UBound(arr)
        If InStr(arr(i, 1), dk) Then
            If Not dic.exists(arr(i, 1)) Then
                a = a + 1
                kq(a, 1) = arr(i, 1)
                dic.Add arr(i, 1), ""
            End If
        End If
    Next i
    Set dic = Nothing
    laygiatri = kq
End Function
=laygiatri(E2,A2:A15)

anh ơi, anh có thể sửa giúp em là khi tìm kiếm chữ hoa hay chữ thường thì nó vẫn tìm được không ạ? Enh cám ơn

 

[sonchuot90]

anh ơi, anh có thể sửa giúp em là khi tìm kiếm chữ hoa hay chữ thường thì nó vẫn tìm được không ạ? Enh cám ơn

Function laygiatri(ByVal dk As String, ByVal mang As Range) As Variant
Dim dic As Object, i As Long, arr, kq() As String, a As Long
Set dic = CreateObject("scripting.dictionary")
arr = mang.Value
ReDim kq(1 To UBound(arr), 1 To 1)
For i = 1 To UBound(arr)
If InStr(arr(i, 1), UCase(dk)) Then
If Not dic.exists(arr(i, 1)) Then
a = a + 1
kq(a, 1) = arr(i, 1)
dic.Add arr(i, 1), ""
End If
End If
Next i
Set dic = Nothing
laygiatri = kq
End Function
Em sửa được rồi ạ