Sortere og flytte celler med tekst.

Sub Kopier_Unikke()

'Opret midlertidig ark "Temp" hvis det ikke findes
If WorksheetFunction.IsErr(Evaluate("Temp" & "!A1")) = True Then
Sheets.Add: ActiveSheet.Name = "Temp"
End If
'Slet data fra sidste kørsel i Temp ark
Range("H2:J65000").Clear

Set sh1 = Sheets("Ark1") ' Ark hvor data er
Set sh2 = Sheets("Temp") ' Ark hvor resultat skrives

sh1.Select
Dim rng2 As New Collection
Dim rng As Range
rk = Cells(Rows.Count, "D").End(xlUp).Row
Set rng = sh1.Range("D2:D" & rk) ' ret range til aktuel

On Error Resume Next
For Each c In rng
  x = c & "#" & c.Offset(0, 1)
  rng2.Add x, CStr(x)
Next
On Error GoTo 0

sh2.Select
t = 1
For Each c In rng2
Cells(t + 1, "H") = Split(c, "#")(0)
  Cells(t + 1, "I") = Split(c, "#")(1)
t = t + 1
Next

Set rng2 = Nothing

'Tæl antal
rk2 = Cells(Rows.Count, "H").End(xlUp).Row
For Each c In Range("H2:H" & rk2)
c.Offset(0, 2) = Application.CountIf(rng, c)
Next

'Sorter
Range("H2:J" & rk2).Sort key1:=Range("J2"), Order1:=xlDescending

Set rng = Nothing

'Kopier 10 øverste til Ark1

Range("H2:J11").Copy sh1.Range("F2")
sh1.Select

End Sub

Sub Kopier_Unikke()

'Opret midlertidig ark "Temp" hvis det ikke findes
If WorksheetFunction.IsErr(Evaluate("Temp" & "!A1")) = True Then
Sheets.Add: ActiveSheet.Name = "Temp"
End If
'Slet data fra sidste kørsel i Temp ark
Range("H2:K65000").Clear

Set sh1 = Sheets("Ark1") ' Ark hvor data er
Set sh2 = Sheets("Temp") ' Ark hvor resultat skrives

sh1.Select
Dim rng2 As New Collection
Dim rng As Range
rk = Cells(Rows.Count, "D").End(xlUp).Row
Set rng = sh1.Range("D2:D" & rk) ' ret range til aktuel

On Error Resume Next
For Each c In rng
  x = c & "#" & c.Offset(0, 1) & "#" & c.Offset(0, 2)
  rng2.Add x, CStr(x)
Next
On Error GoTo 0

sh2.Select
t = 1
For Each c In rng2
Cells(t + 1, "H") = Split(c, "#")(0)
  Cells(t + 1, "I") = Split(c, "#")(1)
  Cells(t + 1, "J") = Split(c, "#")(2)
t = t + 1
Next

Set rng2 = Nothing

'Tæl antal
rk2 = Cells(Rows.Count, "H").End(xlUp).Row
For Each c In Range("H2:H" & rk2)
c.Offset(0, 3) = Application.CountIf(rng, c)
Next

'Sorter
Range("H2:K" & rk2).Sort key1:=Range("K2"), Order1:=xlDescending

Set rng = Nothing

'Kopier 10 øverste til Ark1

Range("H2:K11").Copy sh1.Range("G2")
sh1.Select

End Sub