excel - 宏复制和粘贴并按前 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以显示排名值：

标签： excelvba

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