Function GPE(Rng As Range, DK As Long)
Dim Arr, Res, i As Long, k As Long
Arr = Rng.Value
ReDim Res(1 To UBound(Arr, 1), 1 To 1)
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr, 1)
If Arr(i, 2) = DK Then
If Not .Exists(Arr(i, 1)) Then
k = k + 1
.Add Arr(i, 1), k
Res(k, 1) = Arr(i, 1)
End If
End If
Next
End With
GPE = Res
End Function
Nhìn vào clip mới dễ làm, nghe chỉ dẫn em làm hoài k ra.
Tks anh nha.
anh cho em hỏi đoạn code này có nghĩa là gì vậy:
cám ơn anh em, post file lên nhờ anh xem nhé
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$K$4" Then
Dim adoConn As Object, adoRs As Object
Set adoConn = CreateObject("ADODB.Connection")
Set adoRs = CreateObject("ADODB.Recordset")
With adoConn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & ThisWorkbook.FullName & _
";Extended Properties=""Excel 8.0;HDR=No;IMEX=1"";"
.Open
End With
With adoRs
.ActiveConnection = adoConn
.Open "select distinct f1 from [Sheet1$D5:G5000] where f4=" & Target.Value
End With
[J6:H65000].ClearContents
[J6].CopyFromRecordset adoRs
adoRs.Close: Set adoRs = Nothing
adoConn.Close: Set adoConn = Nothing
End If
End Sub
Code này có thể viết gọn hơn đó.
anh hải ơi, code của anh ok , nhưng có 1 điều nhờ anh sửa lại giúp vì nếu cột điều kiện là số thì đúng còn nếu dạng text thi code báo lỗi
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$K$4" Then
Dim arr(), dk, i
dk = Target.Value
arr = Range("D5", [G65536].End(3)).Value
With CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
If arr(i, 4) = dk Then
If Not .exists(arr(i, 1)) Then
.Add (arr(i, 1)), ""
End If
End If
Next
[J6:J1000].ClearContents
If .Count = 0 Then End
[J6].Resize(.Count) = Application.Transpose(.keys)
End With
End If
End Subdạ tại em còn gà anh ơi, e không nghĩ đến được vậy. bớt nóng anh nhé. cám ơn anh nhiều
em cũng làm đúng như anh nhung vẫn lỗi anh à
Với dữ liệu đơn giản thì có thể tham khảo code này rồi tuỳ biến
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$K$4" Then
[J6:J1000].ClearContents
With Range("G5", [G65536].End(3))
.AutoFilter 1, Target
.Offset(, -3).SpecialCells(12).Copy [J6]
.AutoFilter
End With
Range("J6", [J65536].End(3)).RemoveDuplicates 1
End If
End Subcám ơn anh quang hải
Nếu phải FILTER thì mình thích Advanced Filter hơn:
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$K$4" Then
[IV1] = [G4]: [IV2] = Target.Value: [J5] = [D4]
[D4:G1000].AdvancedFilter 2, [IV1:IV2], [J5], True
[IV1:IV2].ClearContents
End If
End Subanh ơi code của anh thì ok nhưng vẫn còn lỗi này anh ah. ví dụ trong bảng điều kiện có chữ a, và a1 thi luc chọn a thì nó cho ra cả a1 luôn vậy nhờ anh xem lại đoạn này giúp em nhé
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$K$4" Then
[IV1] = [G4]: [COLOR=#ff0000][IV2] = "'=" & Target.Value[/COLOR]: [J5] = [D4]
[D4:G1000].AdvancedFilter 2, [IV1:IV2], [J5], True
[IV1:IV2].ClearContents
End If
End Subđúng rồi đó anh, cám ơn anh nhìu nhìu
