ダミーテーブル作成 ③ 後編

昨日は、一旦ダミーテーブル完成まで漕ぎつけた。
infoment.hatenablog.com

完成して、気が付いた。しまった、入れたい項目を二つ、忘れていた。

入れたかった項目は、以下の二つだ。

1. 原価
2. 値引き額

これから先に、項目を更に増やしたくなるかもしれない。そこで、ラベル情報と対を為す列挙体を作成することにした。これで、多少は変更に強くなるだろう。

加えて、昨日作成したサブプロシージャを、戻り値をテーブルとするユーザー定義関数に変更した。配置位置も、任意に指定できるよう引数に追加。これで、もう少し使い勝手が良くなると思う。

そのままコピペで使用できるよう、現時点でのコードを纏めて記載する。

Option Explicit

Enum ColumnNumber
    cnNo = 1
    cn顧客名
    cn商品コード
    cn商品名
    cn数量
    cn原価
    cn定価
    cn値引き額
    cn合計金額
    cn受注日
    cn約定納期
    cn納入日
    [_eLast]
End Enum

Function FictitiousName(Optional min_length As Long = 3, _
                        Optional max_length As Long = 5) As String

    ' 社名の文字数をランダムに決定。
    Dim NameLength As Long
        NameLength = WorksheetFunction.RandBetween(min_length, max_length)
    
    ' 社名の一文字ずつを格納する配列。
    Dim arr() As String
    ReDim arr(1 To NameLength)
    
    ' 社名の文字数分、あ～んの間で適当に平仮名をセット。
    Dim i As Long
        For i = 1 To NameLength
            arr(i) = Chr(WorksheetFunction.RandBetween(Asc("あ"), Asc("ん")))
        Next
    
    ' 社名の接頭（Prefix）または接尾（Suffix）文字をランダムに決定。
    Dim FixIndex As Long
        FixIndex = WorksheetFunction.RandBetween(0, 6)
    ' とりあえず、これだけ準備。お好みで調整可能。
    Dim FixString(6) As String
        FixString(0) = "（株）"
        FixString(1) = "社団法人"
        FixString(2) = "鉄工所"
        FixString(3) = "商事"
        FixString(4) = "運輸"
        FixString(5) = "電機"
        FixString(6) = "株式会社"
    
    ' 配列を結合して社名作成。
        Select Case FixIndex
            Case 0, 1
                FictitiousName = FixString(FixIndex) & Join(arr, vbNullString)
            Case Else
                FictitiousName = Join(arr, vbNullString) & FixString(FixIndex)
        End Select

End Function

Function CriateDammyTable(destination_range As Range, _
                          Optional record_number As Long = 10) As ListObject
    ' 架空の会社名格納用配列。
    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 [_eLast] - 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, "りんご", 40, 100)
            Dict(2) = Array(1001, "みかん", 90, 200)
            Dict(3) = Array(1002, "ばなな", 60, 150)
            Dict(4) = Array(1003, "なし", 120, 400)
            Dict(5) = Array(1004, "もも", 200, 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, cn顧客名) = FictitiousCompanys(CompanyIndex)
        ' 商品コード。
            ItemIndex = WorksheetFunction.RandBetween(1, 5)
            arr(i, cn商品コード) = Dict(ItemIndex)(0)
        ' 商品名。
            arr(i, cn商品名) = Dict(ItemIndex)(1)
        ' 数量。
            arr(i, cn数量) = WorksheetFunction.RandBetween(1, 20)
        ' 原価。
            arr(i, cn原価) = Dict(ItemIndex)(2)
        ' 定価。
            arr(i, cn定価) = Dict(ItemIndex)(3)
        ' 値引額。※１０円単位で、１０～５０円×数量とする。
            arr(i, cn値引き額) = arr(i, cn数量) * WorksheetFunction.Round(WorksheetFunction.RandBetween(10, 50), -1)
        ' 合計金額。
        ' 受注日。今日から３０日以内。
            arr(i, cn受注日) = Date + WorksheetFunction.RandBetween(1, 30)
        ' 約定納期。受注日＋３～＋７日。
            arr(i, cn約定納期) = arr(i, cn受注日) + WorksheetFunction.RandBetween(3, 7)
        ' 納入日。約定納期±２日。
            arr(i, cn納入日) = arr(i, cn約定納期) + WorksheetFunction.RandBetween(-2, 2)
        Next
    
    ' 作成した配列をシートに貼り付け。
    Dim myRng As Range
    Set myRng = Range("A1").Resize(record_number + 1, [_eLast] - 1)
        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
        
    Set CriateDammyTable = Tb
End Function

Function DataSeriesRange(destination_range As Range, _
                Optional dsStep As Variant = 1, _
                Optional dsStop As Variant = 10, _
                Optional dsRowCol As XlRowCol = xlRows, _
                Optional dsType As XlTrendlineType = xlLinear, _
                Optional dsDate As XlDataSeriesDate = xlDay, _
                Optional dsTrend As Boolean = False) As Range

        On Error GoTo er:

        ' フィル機能でデータセット。
        destination_range.DataSeries dsRowCol, dsType, dsDate, dsStep, dsStop, dsTrend
    
    Dim dsStart As Variant
        ' 初期値の取得。
        ' ※データが入力された範囲の取得用。
        dsStart = destination_range.Cells(1).Value
    
    Dim ResizeIndex As Long
        Select Case dsTrend
            ' データ予測ではない場合。
            Case False
                ' 初期値と停止値、増分値から、データがセットされる行または列数を取得。
                ResizeIndex = WorksheetFunction.RoundDown((dsStop - dsStart) / dsStep, 0) + 1
                Select Case dsRowCol
                    Case xlRows
                        Set DataSeriesRange = destination_range.Resize(, ResizeIndex)
                    Case xlColumns
                        Set DataSeriesRange = destination_range.Resize(ResizeIndex)
                End Select
                
            ' データ予測の場合。
            Case True
                Set DataSeriesRange = destination_range
        End Select

        Exit Function
er:
    Set DataSeriesRange = Nothing
End Function

使い方として、↓ のようなケースを想定している。

Sub test()
    Dim Tb As ListObject
    Set Tb = CriateDammyTable(Range("A3"), 20)
End Sub

これで一応、完成かな。
明日の完結編（恒例の）「もしクラスモジュールにしたら・・・」に続きます。

参考まで。