本文共 2551 字，大约阅读时间需要 8 分钟。

没怎么用过VBA，突然被要求用VBA实现一个简单的抽奖算法，来来回回也花了不少时间，把代码记录下来，为了以后方便查找。

数据源：第一个sheet输入指定数据，含有执行按钮。第二个sheet有3列，第一列是手机号，第二列是手机被使用次数，第三列是手机最早一次被使用的时间

实现1：在手机号中找出与指定数据含有相同数字最多的手机号，如果有多个，找出使用次数最多的，还有多个再看使用时间最早的那个。

Sub luckyPrise()Dim phoneIndex, phoneNumMatchTotal, maxMatch As IntegerDim candidateCol As CollectionDim stockNumMatchDict 'As DictionarySet candidateCol = New CollectionSet stockNumMatchDict = CreateObject("Scripting.Dictionary")Dim stockNumMatch, phoneNumMatch As IntegerFor Num = 0 To 9  stockNumMatch = Len(Sheets("sheet1").Cells(1, 1)) - Len(WorksheetFunction.Substitute(Sheets("sheet1").Cells(1, 1), Num, ""))  stockNumMatchDict.Add Num, stockNumMatchNext Num' debug'For i = 0 To stockNumMatchDict.Count - 1 '重复数组'    MsgBox stockNumMatchDict.Item(i)          '打印条目'Next    phoneIndex = 0maxMatch = 0Do While Sheets("sheet2").Cells(phoneIndex, 1) <> ""  phoneNumMatchTotal = 0  For Num = 0 To 9     phoneNumMatch = Len(Sheets("sheet2").Cells(phoneIndex, 1)) - Len(WorksheetFunction.Substitute(Sheets("sheet2").Cells(phoneIndex, 1), Num, ""))     If phoneNumMatch > stockNumMatchDict.Item(Num) Then         phoneNumMatch = stockNumMatchDict.Item(Num)     End If     phoneNumMatchTotal = phoneNumMatchTotal + phoneNumMatch  Next Num    Sheets("sheet2").Cells(phoneIndex, 5) = phoneNumMatchTotal    If maxMatch < phoneNumMatchTotal Then    maxMatch = phoneNumMatchTotal  End If    phoneIndex = phoneIndex + 1  LoopEnd Sub

实现2：找出与指定数据最后2位一致的手机号码，如果有多个，和实现1相同规则找出唯一一个。

Sub Prise()    Dim phoneNumStr As String    Dim stockLastTwoNumStr As String    Dim phoneNumRowIndex As Integer        stockLastTwoNumStr = ActiveWorkbook.Sheets("Sheet1").Cells(1, 2)    'sort the data with forward numbers descending and first forward data ascending    ActiveWorkbook.Sheets("Sheet2").Columns("A:C").Sort key1:=ActiveWorkbook.Sheets("Sheet2").Range("B2"), _        order1:=xlDescending, Header:=xlYes, key2:=ActiveWorkbook.Sheets("Sheet2").Range("C2"), _        order1:=xlAscending, Header:=xlYes         phoneNumRowIndex = 2        phoneNumStr = ActiveWorkbook.Sheets("Sheet2").Cells(phoneNumRowIndex, 1)        Do While phoneNumStr <> ""        If InStr(10, phoneNumStr, stockLastTwoNumStr) = 10 Then            MsgBox "获奖手机号: " & ActiveWorkbook.Sheets("Sheet2").Cells(phoneNumRowIndex, 1)            Exit Sub        End If                phoneNumRowIndex = phoneNumRowIndex + 1        phoneNumStr = ActiveWorkbook.Sheets("Sheet2").Cells(phoneNumRowIndex, 1)    Loop        MsgBox "没有匹配手机号，选择转发次数最多手机中最早转发的：" & ActiveWorkbook.Sheets("Sheet2").Cells(2, 1)    End Sub

转载地址：http://xbtmb.baihongyu.com/