Dim rCells As Range, rCell As Range, oHosp As Variant, c, nCell As String
Dim oDis As Variant, oH As Integer, oD As Integer
Set rCells = Range("B2", Range("B" & Rows.Count).End(xlUp))
Dim a
With CreateObject("scripting.dictionary")
For Each rCell In rCells
If rCell <> "" Then
If Not .Exists(rCell.Value) Then
.Add rCell.Value, rCells
c = c + 1
End If
End If
Next rCell
oHosp = .keys
End With
'----------
Set rCells = Range("a2", Range("a" & Rows.Count).End(xlUp))
c = 0
With CreateObject("scripting.dictionary")
For Each rCell In rCells
If rCell <> "" Then
If Not .Exists(rCell.Value) Then
.Add rCell.Value, rCells
c = c + 1
End If
End If
Next rCell
oDis = .keys
End With
'==================
Dim sortArray, i As Long, j As Long, temp(1 To 4) As Variant
Dim Rng As Range
ReDim sortArray(1 To UBound(oHosp) + 1, 1 To 4)
For oH = 0 To UBound(oHosp)
c = 0
For oD = 0 To UBound(oDis)
For Each rCell In rCells
If rCell.Offset(, 1) = oHosp(oH) And rCell = oDis(oD) Then
c = c + 1
sortArray(c, 1) = rCell.Offset(, 1)
sortArray(c, 2) = rCell
sortArray(c, 3) = rCell.Offset(, 2)
sortArray(c, 4) = c
End If
Next rCell
Next oD
Dim Last As Integer
For i = 1 To (UBound(sortArray) - 1)
For j = i To UBound(sortArray)
If sortArray(j, 3) > sortArray(i, 3) Then
temp(1) = sortArray(i, 1)
temp(2) = sortArray(i, 2)
temp(3) = sortArray(i, 3)
sortArray(i, 1) = sortArray(j, 1)
sortArray(i, 2) = sortArray(j, 2)
sortArray(i, 3) = sortArray(j, 3)
sortArray(j, 1) = temp(1)
sortArray(j, 2) = temp(2)
sortArray(j, 3) = temp(3)
End If
Next j
Next i
Last = Range("f" & Rows.Count).End(xlUp).Row + 1
Range("f" & Last).Resize(c, 4).Value = sortArray
Next oH