Trợ giúp chỉnh code hàm tìm kiếm và ghép dữ liệu

[NHG]

Chào các bạn
Mình có làm một hàm Dlookup để dò tìm theo cột, kết quả trả về là các giá trị xuất hiện ở cột kết quả
Cấu trúc Dlookup(giá trị cần tìm, cột cần tìm, cột kết quả)
Tuy nhiên nếu trong cột kết quả mà có nhiều giá trị giống nhau thì hàm không loại kết quả trùng được
Các bạn xem giúp mình nhé
M cám ơn.

 

[snow25]

Chào các bạn
Mình có làm một hàm Dlookup để dò tìm theo cột, kết quả trả về là các giá trị xuất hiện ở cột kết quả
Cấu trúc Dlookup(giá trị cần tìm, cột cần tìm, cột kết quả)
Tuy nhiên nếu trong cột kết quả mà có nhiều giá trị giống nhau thì hàm không loại kết quả trùng được
Các bạn xem giúp mình nhé
M cám ơn.
View attachment 236803

Bạn thử nhé.

Function laygiatri(ByVal ten As String, ByVal mang As Range, ByVal so As Integer)
        Dim arr, i As Long, s As String, dk As String, dks As String, s2 As String, s1 As String
            arr = mang.Value
            dk = UCase(ten)
            s1 = "#"
            For i = 1 To UBound(arr)
                If Len(arr(i, 1)) > 0 Then
                   dks = UCase(arr(i, 1))
                   s2 = UCase(arr(i, so))
                   If dk = dks Then
                      If InStr(1, s1, "#" & s2 & "#") = 0 Then
                         s1 = s1 & s2 & "#"
                         s = s & Chr(10) & arr(i, so)
                      End If
                  End If
              End If
          Next i
          If Len(s) Then laygiatri = Right(s, Len(s) - 1)
End Function

=laygiatri(B18,$B$6:$D$11,3)

 

[CHAOQUAY]

Chào các bạn
Mình có làm một hàm Dlookup để dò tìm theo cột, kết quả trả về là các giá trị xuất hiện ở cột kết quả
Cấu trúc Dlookup(giá trị cần tìm, cột cần tìm, cột kết quả)
Tuy nhiên nếu trong cột kết quả mà có nhiều giá trị giống nhau thì hàm không loại kết quả trùng được
Các bạn xem giúp mình nhé
M cám ơn.
View attachment 236803

Function DLOOKUP(lookupval, lookuprange As Range, lookupKQ As Range)
Dim text
Dim rgg1
Dim rgg2
Dim KQ
rgg1 = lookuprange.Value
rgg2 = lookupKQ.Value
For i = 1 To UBound(rgg1)
    If Len(rgg1(i, 1)) > 0 And Len(rgg2(i, 1)) > 0 And LCase(rgg1(i, 1)) = LCase(lookupval) Then
        text = " " & Replace(rgg2(i, 1), " ", "@") & " "
        If InStr(KQ, text) = 0 Then KQ = KQ & text
    End If
Next i
DLOOKUP = Replace(Replace(WorksheetFunction.Trim(KQ), " ", ChrW(10)), "@", " ")
End Function

 

[NHG]

Bạn thử nhé.

Function laygiatri(ByVal ten As String, ByVal mang As Range, ByVal so As Integer)
        Dim arr, i As Long, s As String, dk As String, dks As String, s2 As String, s1 As String
            arr = mang.Value
            dk = UCase(ten)
            s1 = "#"
            For i = 1 To UBound(arr)
                If Len(arr(i, 1)) > 0 Then
                   dks = UCase(arr(i, 1))
                   s2 = UCase(arr(i, so))
                   If dk = dks Then
                      If InStr(1, s1, "#" & s2 & "#") = 0 Then
                         s1 = s1 & s2 & "#"
                         s = s & Chr(10) & arr(i, so)
                      End If
                  End If
              End If
          Next i
          If Len(s) Then laygiatri = Right(s, Len(s) - 1)
End Function

=laygiatri(B18,$B$6:$D$11,3)

Cám ơn bạn nhiều, dùng dễ như hàm vlookup

Bài đã được tự động gộp: 4/5/20

Function DLOOKUP(lookupval, lookuprange As Range, lookupKQ As Range)
Dim text
Dim rgg1
Dim rgg2
Dim KQ
rgg1 = lookuprange.Value
rgg2 = lookupKQ.Value
For i = 1 To UBound(rgg1)
    If Len(rgg1(i, 1)) > 0 And Len(rgg2(i, 1)) > 0 And LCase(rgg1(i, 1)) = LCase(lookupval) Then
        text = " " & Replace(rgg2(i, 1), " ", "@") & " "
        If InStr(KQ, text) = 0 Then KQ = KQ & text
    End If
Next i
DLOOKUP = Replace(Replace(WorksheetFunction.Trim(KQ), " ", ChrW(10)), "@", " ")
End Function

Cảm ơn bạn, mình đã thử và chạy rất ổn, mình chỉ kho biết dùng WorksheetFunction với dữ liệu lớn có làm hàm này chạy chậm đi không
Thêm nữa, mình chưa biết bẫy lỗi, nếu vùng rgg1 hoặc rgg2 chỉ cần có một giá trị là error , n/a... thì hàm dính lỗi value ngay

 

[hocexcel_1991]

Chào các bạn
Mình có làm một hàm Dlookup để dò tìm theo cột, kết quả trả về là các giá trị xuất hiện ở cột kết quả
Cấu trúc Dlookup(giá trị cần tìm, cột cần tìm, cột kết quả)
Tuy nhiên nếu trong cột kết quả mà có nhiều giá trị giống nhau thì hàm không loại kết quả trùng được
Các bạn xem giúp mình nhé
M cám ơn.
View attachment 236803

Bạn tham khảo bài #6

Hàm nối chuỗi từ cột sang dòng

Hi cả nhà, Mình đang muốn nối chuỗi từ cột sang dòng như sau: A B C D E Nối thành: A|B|C|D|E Công thức mình dùng hơi loằng ngoằng và bị giới hạn số lượng dòng ở Cột A. Nhờ các bạn cho cao kiến. Xin cám ơn!

giaiphapexcel.com

 

[NHG]

Nhờ các bạn hỗ trợ sửa code, mình đưa lên hàm (thêm phần bẫy lỗi) để các bạn có thể dùng nếu thấy phù hợp
Function DLOOKUP(lookupval, lookuprange As Range, lookupKQ As Range)
Dim text
Dim rgg1
Dim rgg2
Dim KQ
rgg1 = lookuprange.Value

rgg2 = lookupKQ.Value
'------------
For i = 1 To UBound(rgg1)
If TypeName(rgg1(i, 1)) = "Error" Then
rgg1(i, 1) = ""
End If
If TypeName(rgg2(i, 1)) = "Error" Then
rgg2(i, 1) = ""
End If
'---------------------

If Len(rgg1(i, 1)) > 0 And Len(rgg2(i, 1)) > 0 And LCase(rgg1(i, 1)) = LCase(lookupval) Then
text = " " & Replace(rgg2(i, 1), " ", "@") & " "
If InStr(KQ, text) = 0 Then KQ = KQ & text
End If
Next i
DLOOKUP = Replace(Replace(WorksheetFunction.Trim(KQ), " ", ChrW(10)), "@", " ")
End Function

 

[PacificPR]

Chỗ này hơi khó hiểu

 

[NHG]

Chỗ này hơi khó hiểuView attachment 236835

à, nếu trong vùng tìm kiếm hoặc vùng kết quả mà có ô bị lỗi value, n/a... thì hàm sẽ bị lỗi ngay, mình đưa thêm dòng code vào để kể cả trong vùng điều kiện và vùng kết quả có giá trị lỗi (n/a, value...) thì hàm vẫn chạy bình thường

 

[NHG]

Các bạn xem giúp mình vẫn với bài toán nêu trên, ngoài lọc kết quả trùng ra thì thêm số lần xuất hiện của chuỗi trong kết quả được không nhỉ, mình cảm ơn

 

[snow25]

Các bạn xem giúp mình vẫn với bài toán nêu trên, ngoài lọc kết quả trùng ra thì thêm số lần xuất hiện của chuỗi trong kết quả được không nhỉ, mình cảm ơn
View attachment 236865

Bạn thử code này nhé.

Function laygiatri(ByVal ten As Range, ByVal mang As Range, ByVal so As Integer) As Variant
        Dim arr, kq() As String, data, i As Long, s As String, dk As String, dks As String, dic As Object, a As Long, b As Long, T, s1 As String
        Set dic = CreateObject("scripting.dictionary")
            arr = mang.Value
            a = UBound(arr, 2) + 1
            ReDim Preserve arr(1 To UBound(arr), 1 To a)
            For i = 1 To UBound(arr)
                dk = UCase(arr(i, 1))
                If Not dic.exists(dk) Then
                   dic.Add dk, i
                Else
                   s = dic.Item(dk)
                   s = s & "#" & i
                   dic.Item(dk) = s
                End If
                dk = UCase(arr(i, 1)) & "#" & UCase(arr(i, so))
                If Not dic.exists(dk) Then
                   dic.Add dk, i
                   arr(i, a) = 1
                Else
                   b = dic.Item(dk)
                   arr(b, a) = arr(b, a) + 1
                End If
           Next i
             data = ten.Value
             ReDim kq(1 To UBound(data), 1 To 1)
             For i = 1 To UBound(data)
                 s1 = Empty
                 dk = UCase(data(i, 1))
                 If dic.exists(dk) Then
                    s = dic.Item(dk)
                    For Each T In Split(s, "#")
                        If arr(T, a) Then
                           s1 = s1 & Chr(10) & arr(T, so) & "(" & arr(T, a) & ")"
                        End If
                    Next T
                  If Len(s1) Then kq(i, 1) = Right(s1, Len(s1) - 1)
                 End If
           Next i
           laygiatri = kq()
End Function

=laygiatri(B26:B27,B6:D12,3)

 

[VetMini]

Loại bài này khá thông dụng nhưng người viết code lười biếng chú thích code của mình cho nên có nhiều người cần nhưng không biết là có thể áp dụng được.
Điển hình:

Tìm kiếm tất cả các giá trị, trả về trong 1 ô

Chào các anh chị GPE, Em muốn tìm kiếm dữ liệu trong 1 bảng có sẵn, điều kiện là trả về tất cả các giá trị tương ứng trong 1 ô và không trùng nhau. Trong ví dụ em gửi, em có bảng giá trị là A1B11, mong muốn khi tìm giá trị ở cột D sẽ được kết quả như cột E. Mong các anh chị giúp em viết hàm, em...

giaiphapexcel.com

1. do người hỏi không bao giờ hỏi rõ rệt nên người khác không thể nhận ra là vấn đề của mình cũng giống vậy.
2. người viết không bao giờ có thêm một vài dòng chú thích cho biết hàm làm cái gì và nhận tham ra sao. Người dùng không thể nào biết do mình dùng sai hay do hàm có chỗ lắc léo (có thể do code sai).

 

[NHG]

Bạn thử code này nhé.

Function laygiatri(ByVal ten As Range, ByVal mang As Range, ByVal so As Integer) As Variant
        Dim arr, kq() As String, data, i As Long, s As String, dk As String, dks As String, dic As Object, a As Long, b As Long, T, s1 As String
        Set dic = CreateObject("scripting.dictionary")
            arr = mang.Value
            a = UBound(arr, 2) + 1
            ReDim Preserve arr(1 To UBound(arr), 1 To a)
            For i = 1 To UBound(arr)
                dk = UCase(arr(i, 1))
                If Not dic.exists(dk) Then
                   dic.Add dk, i
                Else
                   s = dic.Item(dk)
                   s = s & "#" & i
                   dic.Item(dk) = s
                End If
                dk = UCase(arr(i, 1)) & "#" & UCase(arr(i, so))
                If Not dic.exists(dk) Then
                   dic.Add dk, i
                   arr(i, a) = 1
                Else
                   b = dic.Item(dk)
                   arr(b, a) = arr(b, a) + 1
                End If
           Next i
             data = ten.Value
             ReDim kq(1 To UBound(data), 1 To 1)
             For i = 1 To UBound(data)
                 s1 = Empty
                 dk = UCase(data(i, 1))
                 If dic.exists(dk) Then
                    s = dic.Item(dk)
                    For Each T In Split(s, "#")
                        If arr(T, a) Then
                           s1 = s1 & Chr(10) & arr(T, so) & "(" & arr(T, a) & ")"
                        End If
                    Next T
                  If Len(s1) Then kq(i, 1) = Right(s1, Len(s1) - 1)
                 End If
           Next i
           laygiatri = kq()
End Function

=laygiatri(B26:B27,B6:D12,3)

Cảm ơn bạn đã nhiệt tình giúp đỡ, mình thử 10.000 dòng dữ liệu vẫn ok, nhưng nhiều hơn thì máy chạy hơi vất, mình sẽ tìm hiểu thêm về code của bản (ít nhất là biết thêm cái ReDim Preserve arr , một lần nữa cảm ơn bạn!