vba实现对人名币玩家的抽奖功能

Option Explicit

Sub 玉帝恩赏迎祥纳福()
    Dim i%, j&, k%, fname$, l%
    Dim r As Range, r1 As Range, b As Workbook, r2 As Range
    fname = "玉帝恩赏，迎祥纳福.csv"
    Set b = Workbooks.Open("C:\Users\admin\Desktop\" & fname)
    b.Activate
    Columns("G:G").Delete
    Columns("F:F").Delete
    Columns("A:A").Delete
    Worksheets(1).Columns("B:B").Cut
    Worksheets(1).Columns("A:A").Insert Shift:=xlToRight
    Set r2 = ActiveSheet.UsedRange
    l = r2.Row + r2.Rows.count - 1

    Do While l <> 1
        If Cells(l, 4) < 200 Then
            Rows(l).Delete
        End If
        l = l - 1
    Loop
    i = 2
    Do While Cells(i, 1) <> ""
        Cells(i, 2) = Cells(i, 2) & " " & Cells(i, 3)
        Cells(i, 4) = Round(Cells(i, 4) / 200, 0)
        j = j + Cells(i, 4)
        i = i + 1
    Loop
    Columns("C:C").Delete
'自动调整列宽
    Columns("A:C").EntireColumn.AutoFit
    Cells(1, 2).Clear
    Cells(1, 3).Clear
    
    Range("D2").FormulaArray = _
        "=INDEX(R1C2:R500C2,SMALL(IF(R1C[-1]:R500C[-1]>=COLUMN(R1:R500),ROW(R1:R500)),ROW(R[-1]C[-2])))"
        
    For i = 2 To (j + 1)
        Range("D" & i).Copy Range("D" & (i + 1))
    Next i
    
    Columns("D:D").Copy
    Columns("E:E").PasteSpecial Paste:=xlPasteValues
    Columns("D:E").EntireColumn.AutoFit
    Columns("B:D").Delete
    For i = 2 To (j + 1)
        Range("C" & i).Copy Range("C" & (i + 1))
        Range("C" & i).Formula = "=rand()"
    Next i
    Range("G1") = "一等奖"
    Range("I1") = "二等奖"
    Range("K1") = "三等奖"
    Range("F2").Formula = "=INDEX(B$2:B$" & j + 1 & ",RANK(C2,C$2:C$" & j + 1 & "))"
    Range("H2").Formula = "=INDEX(B$2:B$" & j + 1 & ",RANK(C2,C$2:C$" & j + 1 & "))"
    Range("J2").Formula = "=INDEX(B$2:B$" & j + 1 & ",RANK(C2,C$2:C$" & j + 1 & "))"
    For i = 2 To 4
        Range("F" & i).Copy Range("F" & (i + 1))
        Range("F" & i).Copy
        Range("G" & i).PasteSpecial Paste:=xlPasteValues
    Next i
    
    For i = 2 To 11
        Range("H" & i).Copy Range("H" & (i + 1))
        Range("H" & i).Copy
        Range("I" & i).PasteSpecial Paste:=xlPasteValues
    Next i
    
    For i = 2 To 31
        Range("J" & i).Copy Range("J" & (i + 1))
        Range("J" & i).Copy
        Range("K" & i).PasteSpecial Paste:=xlPasteValues
    Next i
    Columns("J:J").Delete
    Columns("H:H").Delete
    Columns("F:F").Delete
'自动调整列宽
    Columns("F:H").EntireColumn.AutoFit
End Sub