需求背景

公司會經常籌辦一些內促賽,目的是激勵銷售去創造更多流水.抽獎是常用的以小博大的手段,例如下面方案

在2020年雙十一期間,即11月1日-11日24點,銷售每成交1單,即獲得一份抽獎券.在雙十一結束之後,也就是11月12日,將進行iPhone12的抽獎活動,屆時,抽獎券的數量將會決定銷售的中獎概率

例如公司有3個銷售小紅,小明,小張.他們期間成交的單數及抽獎概率如下表

姓名	成單數	中獎概率
小紅	50	50%
小明	30	30%
小張	20	20%

我們在做模型的時候,一般是從資料庫取數,會形成一張彙總表

部門	組別	姓名	員工工號	成單數	抽獎券數
銷售部	一組	小紅	1	50	50
銷售部	二組	小明	2	30	30
銷售部	三組	小張	3	20	20

但是在抽獎的時候,我們得每一張抽獎券生成一條記錄數.因為抽獎系統比較bug,只能按照行數進行抽獎,所以我們要生成員工姓名*成單數這麼多行數的記錄,也就是100行資料.下面用兩種方法在不脫離Excel環境的情況下實現

PowerQuery實現

Step 1 將表載入到PowerQuery

點選資料表,然後依次點選資料–>從表格,將資料載入到PowerQuery

Step 2 在PowerQuery新增自定義列

依次點選新增列–>自定義列,在自定義列公式輸入下面內容然後確定

={1..[抽獎券數]}

結果會增加一列

Step 3 點選箭頭,擴充套件到新行,完成

點選欄位名右邊的雙向箭頭,選擇擴充套件到新行

然後結果就出來啦

點選主頁–>關閉並上載就可以顯示到Excel工作表中了

VBA實現

實現邏輯

VBA的實現邏輯是這樣的

VBA程式碼

實現程式碼如下,為了方便擴充套件,便將程式碼極可能的變數化

Sub repeatRow()
    Dim Arr
    Dim i%, j%, k%, wRow%
    Dim Sht As Worksheet,OriSht as Worksheet
    Dim t!
    
    Const ORINAME$ = "資料來源"       '資料來源所在表名
    Const SHTNAME$ = "抽獎名單"		'要生成抽獎名單的表名
    Const LASTCOL As Byte = 10	    '抽獎券數所在的列數,可以使用`=COLUMN()`檢視列號,也可以更改R1C1樣式檢視
    Const STARTROW As Byte = 2      '第一行資料所在的行號,從標題開始.所以也是標題所在行號
    
    t = Timer	'計時器
    set OriSht = Sheets(ORINAME)
    
    '將資料來源寫入記憶體
    With OriSht
        Arr = .Range(.Cells(STARTROW, 1), .Cells(.Cells(.Rows.Count, 1).End(3).Row, LASTCOL))
    End With
    
    '預處理:如果出現同名檔案會報錯,所以要先刪除
    Application.DisplayAlerts = 0
    For Each Sht In Worksheets
        If Sht.Name = SHTNAME Then
            Sht.Delete
            Exit For
        End If
    Next
    Application.DisplayAlerts = 1

    '新建表,並將表名修改為指定名稱
    Set Sht = Worksheets.Add(after:=OriSht)
    Sht.Name = SHTNAME
    
    With Sht
        '第一行寫標題
        wRow = 1
        For j = LBound(Arr, 2) To UBound(Arr, 2)
            .Cells(wRow, j).Value = Arr(wRow, j)
        Next

        '第二行開始寫內容
        wRow = 2
        For i = LBound(Arr) + 1 To UBound(Arr)
            If Arr(i, 1) <> "彙總" Then         '判斷第一列是否是彙總兩字,來判斷是否有彙總行
                For k = 1 To Arr(i, LASTCOL)
                    For j = LBound(Arr, 2) To UBound(Arr, 2)
                        .Cells(wRow, j).Value = Arr(i, j)
                    Next
                    wRow = wRow + 1
                Next
            End If
        Next
    End With
    MsgBox "耗時:" & Format(Timer - t, "0.0s"), vbInformation, SHTNAME & "生成完成"
End Sub

附錄

不知道如何執行VBA程式碼?參照下面這篇文章

如何執行一個巨集