階層がある項目に枝番をふります。
エラーチェックは入れていないので、
枝番をふられる対象の項目が、
ちゃんと書かれていることが前提。
枝番の階層を変更したいときは、
ワークシートの列を増減させて、
LEVEL_NUMに何階層まであるか、
eCOLに追加した列の分のを足してください。
Enumで全列定義しているのは、
わたしが枝番をふる以外のこともしたいからです。
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 |
Option Explicit '--------------------------------------------------------------------------------------------------- ' 定義 '--------------------------------------------------------------------------------------------------- Const DATA_START_ROW As Integer = 4 'データ開始行 Const LEVEL_NUM As Integer = 3 'レベルの階層 Private Enum eCOL '列インデックス Level1 = 1 Level2 Level3 ' Level4 項目Lv1 項目Lv2 項目Lv3 ' 項目Lv4 TRAILER End Enum '--------------------------------------------------------------------------------------------------- '【処 理 名】採番処理 '【処理概要】記述されている階層に応じて枝番をふる '【引 数】なし '【返 却 値】なし '--------------------------------------------------------------------------------------------------- Public Sub 採番() Dim sh As Worksheet 'ワークシートオブジェクト Dim items() As Variant 'ワークシートデータ格納領域 Dim serialNumber(LEVEL_NUM - 1) As Variant '採番作業領域 Dim endRowIndex As Long 'ワークシート末尾行 Dim rowIndex As Long '行インデックス 'ワークシートオブジェクト取得 Set sh = ThisWorkbook.Worksheets("Sheet1") '末尾行取得 endRowIndex = getEndRow(sh) For rowIndex = DATA_START_ROW To endRowIndex '配列に格納 items = sh.Range(sh.Cells(rowIndex, eCOL.項目Lv1), _ sh.Cells(rowIndex, eCOL.項目Lv1 + LEVEL_NUM - 1)) '枝番配列生成 Call createLevelArray(items, serialNumber) 'ワークシートへ書き込み sh.Range(sh.Cells(rowIndex, eCOL.Level1), _ sh.Cells(rowIndex, eCOL.Level1 + LEVEL_NUM - 1)) = serialNumber Next Set sh = Nothing End Sub '--------------------------------------------------------------------------------------------------- '【処 理 名】末尾行取得 '【処理概要】項目レベル11~項目レベル13の中で、最大の末尾行を取得する '【引 数】[I]ByVal sh As Worksheet ワークシートオブジェクト '【返 却 値】末尾行数 '--------------------------------------------------------------------------------------------------- Private Function getEndRow(ByVal sh As Worksheet) As Long Dim endRowIndex As Long '末尾行数取得領域 Dim colIndex As Long '列インデックス getEndRow = 0 For colIndex = eCOL.項目Lv1 To eCOL.TRAILER - 1 '末尾行取得 endRowIndex = sh.Cells(Rows.Count, colIndex).End(xlUp).Row '今まで取得した末尾行より大きい場合は、その値を取得する If getEndRow < endRowIndex Then getEndRow = endRowIndex End If Next End Function '--------------------------------------------------------------------------------------------------- '【処 理 名】レベル取得 '【処理概要】何階層まで記載されているかを取得する '【引 数】[I]items() As Variant ワークシートの項目を格納した配列 '【返 却 値】レベル '--------------------------------------------------------------------------------------------------- Private Function getLevel(items() As Variant) As Integer Dim index As Integer '列インデックス getLevel = LEVEL_NUM '配列の要素数 For index = 1 To LEVEL_NUM - 1 'どこまで記載があるかで枝番のレベルを判定する If items(1, index) <> "" Then getLevel = index Exit Function End If Next index End Function '--------------------------------------------------------------------------------------------------- '【処 理 名】採番情報生成 '【処理概要】ワークシートに書き込むための採番情報を配列に格納する '【引 数】[I]ByVal level As Integer 階層 ' [I/O]ByRef serialNumber() As Variant 採番情報格納配列 '【返 却 値】なし '--------------------------------------------------------------------------------------------------- Private Sub createLevelArray(items() As Variant, ByRef serialNumber() As Variant) Dim level As Integer '階層 Dim branch As Integer '現在の番号 'レベル取得 level = getLevel(items) '該当レベルの次の番号を取得する branch = IIf(serialNumber(level - 1) = "", 0, serialNumber(level - 1)) + 1 '該当レベルより下の枝番はクリアする Call clearSerialNumberBranch(serialNumber, level) '該当レベルの番号を設定する serialNumber(level - 1) = branch End Sub '--------------------------------------------------------------------------------------------------- '【処 理 名】枝番クリア '【処理概要】該当レベルより下の枝番はクリアする '【引 数】[I/O]ByRef serialNumber() As Variant 採番情報格納配列 ' [I]ByVal level As Integer 階層 '【返 却 値】なし '--------------------------------------------------------------------------------------------------- Private Sub clearSerialNumberBranch(ByRef serialNumber() As Variant, ByVal level As Integer) Dim index As Integer '配列要素インデックス For index = level To UBound(serialNumber) serialNumber(index) = "" Next End Sub |