Макрос Копирование и вставка и сортировка по значению Top 3 (или более)

Question

У меня есть дело, чтобы скопировать и вставить значение в новый столбец, удалить дубликаты и отсортировать по большому значению топ-3.

Вот моя таблица:

Это мой текущий код для копирования в новый столбец:

 Columns("I:J").EntireColumn.Delete
 LRow = sht.Range("A" & Rows.Count).End(xlUp).Row
    .Range("A1:A" & LRow).Copy: .Range("I1").PasteSpecial xlPasteValues
    .Range("C1:C" & LRow).Copy: .Range("J1").PasteSpecial xlPasteValues

    .Range("I:J", .Range("I:J").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo

Но этот код только копирует и удаляет дубликаты из столбцов A & C и копирует в столбцы J & K.

Это результат, который мне нужен, когда при копировании и удалении дубликата я просто хочу показать топ-3 большого значения, как на этом рисунке (Столбец J & K), и добавить новый столбец Rank, чтобы показать значение ранга:

Answer 1

Этот код можно использовать как для вашей цели:

Sub GetRank()
    Dim mySheet As Worksheet
    Set mySheet = Sheets("Sheet1") 'Ubah Nama Sheet Sesuai Aktual

    'In this sample, only until row 12, can be changed with last row

    mySheet.Range("J1:K12").ClearContents
    mySheet.Range("A1:A12,C1:C12").Copy mySheet.Range("J1")
    mySheet.Range("I1").Value = "Rank"
    mySheet.Range("I2").Value = "1"
    mySheet.Range("I3").Value = "2"
    mySheet.Range("I4").Value = "3"
    mySheet.Range("J2:K12").RemoveDuplicates Columns:=Array(1, 2), Header:=xlNo

    mySheet.Sort.SortFields.Clear
    mySheet.Sort.SortFields.Add Key:=Range("K2:K12") _
        , SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    mySheet.Sort.SortFields.Add Key:=Range("J2:J12") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With mySheet.Sort
        .SetRange Range("J1:K12")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    mySheet.Range("J5:K12").ClearContents
End Sub