1. 程式人生 > 其它 >vba實現對人名幣玩家的抽獎功能

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