【VBA】枝番を振る

筆箱にカンニングペーパーを入れる係のみすくです。こんにちは。
VBA関連だけまとめたブログもあります。
筆箱VBA

階層がある項目に枝番をふります。
エラーチェックは入れていないので、
枝番をふられる対象の項目が、
ちゃんと書かれていることが前提。

枝番の階層を変更したいときは、
ワークシートの列を増減させて、
LEVEL_NUMに何階層まであるか、
eCOLに追加した列の分のを足してください。
Enumで全列定義しているのは、
わたしが枝番をふる以外のこともしたいからです。

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

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

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

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) = ""

End Sub

コメントを残す コメントをキャンセル

コメントを残すコメントをキャンセル