Tìm kiếm theo nhiều điều kiện (1 người xem)

[Cá ngừ F1]

E có tình huống chưa biết xử lý thế nào
Câu hỏi e có nêu theo file đính kèm
E muốn sử dụng Code, vì dùng hàm nặng nề quá...
Không biết tên chủ đề có sát với câu hỏi không? mong các thành viên giúp đỡ...
E xin cảm ơn !

 

[Let'GâuGâu]

E có tình huống chưa biết xử lý thế nào
Câu hỏi e có nêu theo file đính kèm
E muốn sử dụng Code, vì dùng hàm nặng nề quá...
Không biết tên chủ đề có sát với câu hỏi không? mong các thành viên giúp đỡ...
E xin cảm ơn !

hết giờ làm, chuẩn bị về, để ké lên đây, làm về nha test lại cho bạn

Sub Code()

Dim sArr As Variant, kq(), dic As Object
ReDim kq(1 To UBound(sArr), 1 To 5)
Set dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(sArr)
If Not dic.Exists(sArr(i, 1)) Then
    dic.Add sArr(i, 1), ""
    k = k + 1
    kq(k, 1) = sArr(i, 1)
Else
    For Each v In dic.keys
        If sArr(i, 1) = v Then
            j = j + 1
            kq(j, 1) = sArr(i, 1)
        End If
    Next
End If



End Sub

 

[quocphuoc88]

Sub GPE()
Dim Sarr(), Arr(), i As Long, j As Long, Dic As Object
With Sheet1
    Sarr = .Range("A2:E14").Value
    ReDim Arr(1 To UBound(Sarr, 1), 1 To 5)
    Set Dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(Sarr, 1)
        If Not Dic.Exists(Sarr(i, 1)) Then
            j = j + 1
            Dic.Add Sarr(i, 1), j
            Arr(j, 1) = Sarr(i, 1)
            Arr(j, 2) = Sarr(i, 2)
            Arr(j, 3) = Sarr(i, 3)
            Arr(j, 4) = Sarr(i, 4)
            Arr(j, 5) = Sarr(i, 5)
        Else
            Arr(Dic.Item(Sarr(i, 1)), 2) = Sarr(i, 2)
            Arr(Dic.Item(Sarr(i, 1)), 3) = Sarr(i, 3)
            Arr(Dic.Item(Sarr(i, 1)), 4) = Sarr(i, 4)
            Arr(Dic.Item(Sarr(i, 1)), 5) = Sarr(i, 5)
        End If
    Next i
    If j Then
        .Range("I7").Resize(j, 5).Value = Arr
    End If
End With


End Sub

Thử xem nhé !

 

[phucbugis]

hết giờ làm, chuẩn bị về, để ké lên đây, làm về nha test lại cho bạn
...

khà khà, sao thấy bác bài nào cũng đem "Dic" ra dùng hết vậy.
thêm 1 code nữa cho bác F1 test.

Sub GPE_test()
Dim lastRow As Long
Dim rng As Range, vung As Range
Application.ScreenUpdating = False
    Set vung = Range("I2:I5")
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    For Each rng In vung
    For i = lastRow To 2 Step -1
        If Cells(i, 1) = rng Then
            rng.Offset(, 1).Resize(, 4) = Cells(i, 1).Offset(, 1).Resize(, 4).Value
            GoTo Next_
        End If
    Next
Next_:
    Next
Application.ScreenUpdating = True
End Sub

 

[PhanTuHuong]

Em thử nghiên cứu code này, thay đổi copy cả vùng cũng được.

Sub LocDuyNhat()
Dim VungLoc As Range, Oloc As Range
Dim i As Integer
Set VungLoc = Range(Range("A2"), Range("A2").End(xlDown))
VungLoc.Select
j = 0
'Duyet tung ô
With Range("A1")
For i = 1 To VungLoc.Rows.Count
If .Offset(i, 0) <> .Offset(i + 1, 0) Then
j = j + 1
'Ma_so
Range("I1").Offset(j, 0) = .Offset(i, 0)
'STT
Range("I1").Offset(j, 1) = .Offset(i, 1)
End If
Next
End With
Set VungLoc = Nothing
End Sub

 

[Cá ngừ F1]

Em thử nghiên cứu code này, thay đổi copy cả vùng cũng được.

Code này của thầy nhìn rất dễ hiểu, có thể điều chỉnh được..
E mới chớm VBA nên quả thật mấy khái niệm "Scripting.Dictionary" như a quocphuoc88, Let'GâuGâu, ... có sử dụng e chưa biết là j. Mong các thành viên chỉ dậy..
E xin cảm ơn...

 

[Let'GâuGâu]

khà khà, sao thấy bác bài nào cũng đem "Dic" ra dùng hết vậy.

[/CODE]

biết chỉ có một cách đó thui...........ko chơi nó lấy gì mà "chống" lại được chú...........kakakak
thui lỡ leo lưng cọp rồi thì làm luôn vậy................hihihi

Sub Code()

Dim sArr As Variant, kq(), dic As Object
sArr = [a2:e14].Value
ReDim kq(1 To UBound(sArr), 1 To 5)
Set dic = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(sArr)
l = 0
If Not dic.Exists(sArr(i, 1)) Then
    dic.Add sArr(i, 1), ""
    k = k + 1
    For j = 1 To UBound(sArr, 2)
        kq(k, j) = sArr(i, j)
    Next
Else
    For Each v In dic.keys
     l = l + 1
        If sArr(i, 1) = v Then
            For j = 2 To UBound(sArr, 2)
                kq(l, j) = sArr(i, j)
            Next
        End If
    Next
End If
Next
[i7].Resize(k, 5).ClearContents
[i7].Resize(k, 5).Value = kq
Set dic = Nothing
End Sub

===============
hihhiih
chưa đọc bài của bạn QuocPhuoc88, bài của bạn ấy hay hơn...kakakak

 

[Ba Tê]

khà khà, sao thấy bác bài nào cũng đem "Dic" ra dùng hết vậy.
thêm 1 code nữa cho bác F1 test.

Sub GPE_test()
Dim lastRow As Long
Dim rng As Range, vung As Range
Application.ScreenUpdating = False
    Set vung = Range("I2:I5")
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    
    For Each rng In vung
    For i = lastRow To 2 Step -1
        If Cells(i, 1) = rng Then
            rng.Offset(, 1).Resize(, 4) = Cells(i, 1).Offset(, 1).Resize(, 4).Value
            GoTo Next_
        End If
    Next
Next_:
    Next
Application.ScreenUpdating = True
End Sub

Nếu không Dic thì với dữ liệu đã được sắp xếp liên tục như vậy, thử thêm 1 cái "Củ chuối" này xem sao:
(Lỡ mang bệnh "mảng" tính rồi)
[GPECODE=vb]Sub CuChuoi()
Dim sArr(), dArr(), I As Long, J As Long, K As Long
sArr = Range([A2], [A2].End(xlDown).Offset(1)).Resize(, 5).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For I = 1 To UBound(sArr, 1) - 1
If sArr(I, 1) <> sArr(I + 1, 1) Then
K = K + 1
For J = 1 To 5
dArr(K, J) = sArr(I, J)
Next J
End If
Next I
[I2].Resize(K, 5) = dArr
End Sub[/GPECODE]

 

[Cá ngừ F1]

Giải pháp tốt cho người mới bắt đầu

E có dùng AdvanceFilter -> có vẻ dễ dàng và ngắn gọn hơn cho người mới chập chững bước vào VBA
Criteria như sau:

=COUNTIF($A$2:$A$14,$A2)=$B2

Code VBA

Sub Code()
'Lay ma duy nhat
    With Sheet1
    .[A1:E14].AdvancedFilter 2, .[G6:G7], .[I1:M1]
    End With
End Sub