VBA使用记录

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

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

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

Sub luckyPrise()

Dim phoneIndex, phoneNumMatchTotal, maxMatch As Integer
Dim candidateCol As Collection
Dim stockNumMatchDict 'As Dictionary

Set candidateCol = New Collection
Set stockNumMatchDict = CreateObject("Scripting.Dictionary")
Dim stockNumMatch, phoneNumMatch As Integer


For Num = 0 To 9
  stockNumMatch = Len(Sheets("sheet1").Cells(1, 1)) - Len(WorksheetFunction.Substitute(Sheets("sheet1").Cells(1, 1), Num, ""))
  stockNumMatchDict.Add Num, stockNumMatch
Next Num


' debug
'For i = 0 To stockNumMatchDict.Count - 1 '重复数组
'    MsgBox stockNumMatchDict.Item(i)          '打印条目
'Next
    
phoneIndex = 0
maxMatch = 0
Do 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
  
Loop
End 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

</pre><pre code_snippet_id="582473" snippet_file_name="blog_20150117_4_2259042" name="code" class="html">