Option Explicit
Public Sub LocTrung()
Dim Dic As Object, sArr(), Kq(), WF As Object
Dim i As Long, j As Long, k As Long, d As Long, Lr As Long, dem As Long
Set Dic = CreateObject("Scripting.Dictionary"): Set WF = Application.WorksheetFunction
Lr = Sheet1.Range("D65536").End(xlUp).Row: sArr = Sheet1.Range("B9:E" & Lr)
ReDim Kq(1 To UBound(sArr), 1 To 3)
For i = 1 To UBound(sArr)
If Not Dic.Exists(sArr(i, 3)) Then
Dic.Add sArr(i, 3), 1
End If
Next i
For j = 1 To UBound(sArr)
If WF.CountIf(Sheet1.Range("D9:D" & Lr), sArr(j, 3)) > 1 Then
d = d + 1
For k = 1 To 3
Kq(d, k) = sArr(j, k + 1)
Next k
End If
Next j
Sheet1.Range("G9:I65536").ClearContents
Sheet1.Range("G9").Resize(d, 3) = Kq
Sheet1.Range("G9").Resize(d, 3).Sort key1:=Sheet1.Range("H9")
End Sub