ダミーテーブル作成　② 中編 - Infomentのブログ～Excel VBA奮闘記～

昨日は、テスト用のダミーテーブルを途中まで作成して、時間切れ。
infoment.hatenablog.com

今日は、昨日の続き。
f:id:Infoment:20200108212737p:plain

昨日は、このような表を張り付けるところまで作成した。
f:id:Infoment:20200107232154p:plain

この表は、No.と合計金額の列を空欄にしてある。理由は、以下のとおり。

合計金額・・・「単価×数量」の数式をセットするため。
No. ・・・「受注日」で昇順ソートしたあとに、通し番号をつけるため。

ということで、昨日のものに追加したのがこちら。

Sub CriateDammyTable(Optional record_number As Long = 10)
    ' 架空の会社名格納用配列。
    Dim FictitiousCompanys() As String
    ' 会社名の数は、レコード数の二分の一とする（切り下げ）。
    ReDim FictitiousCompanys(1 To WorksheetFunction.RoundDown(record_number / 2, 0))
    Dim i As Long
    ' 架空の会社名で配列作成。
        For i = 1 To UBound(FictitiousCompanys)
            FictitiousCompanys(i) = FictitiousName
        Next
    ' テーブルのラベル用配列。
    Dim LabelArray As Variant
        LabelArray = Array("No.", "顧客名", "商品コード", "商品名", "数量", "単価", "合計金額", "受注日", "約定納期", "納入日")
    Dim arr() As Variant
    ReDim arr(0 To record_number, 1 To UBound(LabelArray) + 1)
    
    ' ０行目にラベルセット。
        For i = 0 To UBound(LabelArray)
            arr(0, i + 1) = LabelArray(i)
        Next
    
    ' 商品コードと品名等の辞書作成。5品番作成。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
        For i = 1 To 5
            ' 配列内は商品コード，商品名，単価の順。
            Dict(1) = Array(1000, "りんご", 100)
            Dict(2) = Array(1001, "みかん", 200)
            Dict(3) = Array(1002, "ばなな", 150)
            Dict(4) = Array(1003, "なし", 400)
            Dict(5) = Array(1004, "もも", 300)
        Next
    
    ' レコード作成。
    Dim CompanyIndex As Long
    Dim ItemIndex As Long
        For i = 1 To record_number
        ' No.
        ' 顧客名。
            CompanyIndex = WorksheetFunction.RandBetween(1, UBound(FictitiousCompanys))
            arr(i, 2) = FictitiousCompanys(CompanyIndex)
        ' 商品コード。
            ItemIndex = WorksheetFunction.RandBetween(1, 5)
            arr(i, 3) = Dict(ItemIndex)(0)
        ' 商品名。
            arr(i, 4) = Dict(ItemIndex)(1)
        ' 数量。
            arr(i, 5) = WorksheetFunction.RandBetween(1, 20)
        ' 単価。
            arr(i, 6) = Dict(ItemIndex)(2)
        ' 合計金額。
        ' 受注日。今日から３０日以内。
            arr(i, 8) = Date + WorksheetFunction.RandBetween(1, 30)
        ' 約定納期。受注日＋３～＋７日。
            arr(i, 9) = arr(i, 8) + WorksheetFunction.RandBetween(3, 7)
        ' 納入日。約定納期±２日。
            arr(i, 10) = arr(i, 9) + WorksheetFunction.RandBetween(-2, 2)
        Next
    
    '-------------------本日追加↓↓↓-----------------------------
    
    ' 作成した配列をシートに貼り付け。
    Dim myRng As Range
    Set myRng = Range("A1").Resize(record_number + 1, 10)
        myRng.Value = arr
        
    ' 貼り付けた表をテーブル化。
        ActiveSheet.ListObjects.Add(xlSrcRange, myRng, , xlYes).Name = "Table_" & Format(Now, "yyyymmdd_hhmmss")
    Dim Tb As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
        Tb.TableStyle = "TableStyleLight13"
    
    ' 配列作成時に空欄だった「合計金額」に、計算式をセット。
        With Tb.ListColumns("合計金額").DataBodyRange
            .Value = "=[@数量]*[@単価]"
            .Style = "Comma [0]"
        End With
    
    ' テーブルを受注日で昇順ソート。
        With Tb.Sort
            .SortFields.Clear
            .SortFields.Add2 Key:=Tb.ListColumns("受注日").DataBodyRange.Cells(1), _
                             SortOn:=xlSortOnValues, _
                             Order:=xlAscending, _
                             DataOption:=xlSortNormal
        End With
    
        With Tb.Sort
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        
    ' ソート後に、「No.」列に通し番号をセット。
        Tb.ListColumns("No.").DataBodyRange.Cells(1) = 1
        DataSeriesRange Tb.DataBodyRange.Columns(1), , , xlColumns, , , True
    
    ' 日付の表示形式を整える。
        Tb.ListColumns("受注日").DataBodyRange.Resize(, 3).NumberFormatLocal = "yyyy/mm/dd"
    
    ' セルの幅を自動調整。
        Cells.EntireColumn.AutoFit
        
End Sub