COBOLのCOPY句をExcelの表にする④

前回までの説明のリンク

COBOLのCOPY句をExcelの表にする①
COBOLのCOPY句をExcelの表にする②
COBOLのCOPY句をExcelの表にする③

桁位置計算ツール全貌

今回作成した桁位置計算ツールの全貌は以下のとおりである。全貌とは言っても今回は「桁位置計算部分」しか作ってないので、その他の部分は中途半端である。（気が向いたらそのうち全て作ることにする）
ツールのファイル名は何でも良いが、今回は「COPY句レイアウト表作成ツール.xlsm」としている。

コピー句テキストファイル

今回はあまり重要ではなかったが、コピー句テキストファイルは以下のとおり。

COPY0001.txt

000000*  レコード名：サンプルレコード
000000*
000000 01  ＸＸサンプルレコード.
000000   03  ＸＸ集団項目０１.
000000     05  ＸＸ項目０１                      PIC  9(02).
000000     05  ＸＸ項目０２.
000000       07  ＸＸ項目０２Ａ                  PIC  X(05).
000000       07  ＸＸ項目０２Ｂ                  PIC  X(05).
000000     05  ＸＸ項目０２－１                  REDEFINES ＸＸ項目０２.
000000       07  ＸＸ項目０２－１－１            PIC  X(02).
000000       07  ＸＸ項目０２－１－２            PIC  9(03).
000000       07  ＸＸ項目０２－１－３            PIC  X(04).
000000       07  ＸＸ項目０２－１－４            PIC  9(01).
000000     05  ＸＸ項目０２－２                  REDEFINES ＸＸ項目０２.
000000       07  ＸＸ項目０２－２－１            PIC  9(07).
000000       07  ＸＸ項目０２－２－２            PIC  9(02).
000000   03  FILLER                              PIC  X(07).
000000   03  ＸＸ項目０３年月日.
000000     05  ＸＸ項目０３年                    PIC  9(04).
000000     05  ＸＸ項目０３月                    PIC  9(02).
000000     05  ＸＸ項目０３日                    PIC  9(02).
000000   03  ＸＸ項目０４.
000000     05  ＸＸ項目０４Ａ                    OCCURS 2.
000000       07  ＸＸ項目０４Ｂ                  OCCURS 3 TIMES.
000000         09  ＸＸ項目０４Ｃ                OCCURS 4 TIMES.
000000           11  ＸＸ売上金額
000000                                           PIC  S9(10) COMP-3.
000000           11  ＸＸ売上数
000000                                           PIC  S9(09) COMP-3.
000000           11  ＸＸ利益額
000000                                           PIC  S9(10) COMP-3.
000000   03  ＸＸ項目０５                        PIC  X(02) OCCURS 5.
000000   03  ＸＸ項目０５Ｒ                      REDEFINES  ＸＸ項目０５ 
000000                                           PIC  9(03) OCCURS 3 TIMES.
000000   03  FILLER                              PIC  X(15).

コピー句レイアウト表

私がいつも本職で使用しているコピー句レイアウト表は以下のとおり。

設定画面

Sheet名は長年の癖で「Main」としている。COPY句テキストファイルからCOPY句レイアウト表を作成する部分は未搭載である。各ボタンIDは任意で、デフォルトで付くID「CommandButton1」でも全然問題ない。自分で分かれば良い。ちなみに全て「ActiveXコントロール」を使用している。

画面構成について

設定画面の構成は自由に作って構わないのだが、使う人が迷わない造りにした方が良い。自分しか使わないのであれば綺麗に作る必要もなく、自分だけが使い方を知っていれば良い。自分以外の人の使用も予想されるのであれば、最初からそのつもりで部品配置を考えた方が後々楽である。

Sheet1(Main)

Sheet1(Main)

Option Explicit

Private Sub Btn_CopyLayoutSelect_Click()
    
    Dim Target As String
    
    Target = Application.GetOpenFilename("Excel Book,*.xlsx?")
    If Target = "False" Then
        Exit Sub
    End If

    Workbooks(ActiveWorkbook.Name).Worksheets(ActiveSheet.Name).Range("C8").Value = Target
    CBox_SheetName.Clear

End Sub

Private Sub Btn_CopyTextFileSelect_Click()
    
    Dim Target As String
    
    Target = Application.GetOpenFilename("Text File,*.txt?")
    If Target = "False" Then
        Exit Sub
    End If

    Workbooks(ActiveWorkbook.Name).Worksheets(ActiveSheet.Name).Range("C4").Value = Target

End Sub

Private Sub Btn_CreateCopyLayout_Click()
    
    '各種エラーチェックを記載すること
    'ファイルの存在チェックもここで実施する
    '同名のファイルが開いてないかチェックする
    '...
    
    'COPY句レイアウト表作成処理
    Call CreateCopyLayout

End Sub

Private Sub Btn_GetSheetName_Click()
    
    '各種エラーチェックを記載すること
    'ファイルの存在チェックもここで実施する
    '同名のファイルが開いてないかチェックする
    '...
    
    'コンボボックスにSheet名を追加
    Call AddSheetName

End Sub

Private Sub Btn_ReculcDigitPos_Click()
    
    '各種エラーチェックを記載すること
    'ファイルの存在チェックもここで実施する
    '同名のファイルが開いてないかチェックする
    '...
    
    '桁位置再計算処理
    Call DigitPositionCalculationProcess
    
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    If Target.Column = 3 And Target.Row = 8 Then
        CBox_SheetName.Value = ""
        CBox_SheetName.Clear
    End If

End Sub

今回、かなり端折ってコードを書いている。本来、自分で作成する際には、入力項目は処理を行う前に必ずチェックするようにしている。Excel Bookを指定した場合も、ボタンを押下した時に必ず存在チェックを行い、ファイルがパス上に存在することを確認してメインの処理に渡すようにする。
例えば、今回のCOPY句レイアウト表の桁位置計算処理であれば、以下のチェックを実施し問題なければ桁位置計算処理へ制御を渡す。そうすればメインの桁位置計算処理では余計なチェックが不要となる。

• ファイルの存在チェック
• 同名のファイルが開いてないかどうかのチェック
• 指定されたファイルがCOPY句レイアウト表かどうかのチェック（例えばExcelの見出しの形が合っているかどうかなど）

Module1.bas

「Module1.bas」を全て記載する。

Module1.bas

Option Explicit

'制御情報の構造体定義
Type ControlArray
    Str_Category As String      '区分。R:REDEFINES,O:OCCURSを示す
    Int_Level As Integer        'LEVELを数値化した値
    Int_OccursNum As Integer    '区分=Oの場合「回数」を管理
    Lng_RedefinesPos As Integer '区分=Rの場合「再定義元次の桁位置」を管理
    Int_NowOccursNum As Integer '区分=Oの場合の現在の繰り返し数を管理
    Lng_Row As Long             'REDEFEINS,OCCURSが出現したExcel行位置
End Type

'制御配列(動的配列)のオブジェクト定義
Dim CA(9) As ControlArray

'各種管理変数
Dim Idx1 As Long      '制御配列Index
Dim Lng_NowRow        '現在Excel行位置
Dim Lng_NextDigitPos  '次行桁位置

'各種オブジェクト変数
Dim MainSheet As Object
Dim EditSheet As Object
Dim EditBook As Object

'変数定義
Dim Str_ExcelFileFullPath As String
Dim Str_ExcelFileName As String
Dim Str_ExcelFilePath As String
Dim Str_SheetName As String



'*********************************
'** COPY句レイアウト表作成処理
'*********************************
Public Sub CreateCopyLayout()

    Call DigitPositionCalculationProcess
    
End Sub


'*********************************
'** 桁位置再計算処理
'*********************************
Public Sub DigitPositionCalculationProcess()
    
    Dim Int_Error As Integer
    
    Call StartProc

    Set MainSheet = Workbooks(ActiveWorkbook.Name).Worksheets(ActiveSheet.Name)

    'フルパスからファイル名とパスを取得
    Str_ExcelFileFullPath = Trim(MainSheet.Range("C8").Value)
    Call GetFilNameAndPath(Str_ExcelFileFullPath, Str_ExcelFilePath, Str_ExcelFileName)
    
    '対象のSheet名
    Str_SheetName = MainSheet.CBox_SheetName.Value
    
    Workbooks.Open Str_ExcelFileFullPath
    'Sheet名はコンボボックスで指定したもの
    Set EditSheet = Workbooks(Str_ExcelFileName).Worksheets(Str_SheetName)
    
    '桁位置（F列）のクリアと見出しの再設定
    EditSheet.Columns("F:F").ClearContents
    EditSheet.Range("F1").Value = "桁位置"
    
    '桁位置計算処理
    Int_Error = 0
    If ReculcDigitPos() = 0 Then
        '項目名見出しにレコード長の編集
        EditSheet.Range("B1").Value = "項目名(レコード長:" & Lng_NextDigitPos - 2 & ")"
    Else
        MsgBox "コピー句に誤りがあり桁位置計算ができません。確認してください。", vbOKOnly, "コピー句エラー"
    End If
    
    Set EditSheet = Nothing
    Set MainSheet = Nothing
    'ファイルを保存してcloseする
    Workbooks(Str_ExcelFileName).Close savechanges:=True
    
    Call EndProc
    
End Sub


'*********************************
'** コンボボックスにsheet名を追加
'*********************************
Public Sub AddSheetName()
    
    Dim ws As Worksheet
    
    Call StartProc

    Set MainSheet = Workbooks(ActiveWorkbook.Name).Worksheets(ActiveSheet.Name)
    
    'フルパスからファイル名とパスを取得
    Str_ExcelFileFullPath = Trim(MainSheet.Range("C8").Value)
    Call GetFilNameAndPath(Str_ExcelFileFullPath, Str_ExcelFilePath, Str_ExcelFileName)
    
    Workbooks.Open Filename:=Str_ExcelFileFullPath, ReadOnly:=True
    Set EditBook = Workbooks(ActiveWorkbook.Name)
    
    MainSheet.CBox_SheetName.Value = ""
    MainSheet.CBox_SheetName.Clear
    
    '全sheet名を追加
    For Each ws In EditBook.Worksheets
        MainSheet.CBox_SheetName.AddItem ws.Name
    Next ws
    
    Set EditBook = Nothing
    Set MainSheet = Nothing
    Workbooks(Str_ExcelFileName).Close savechanges:=False
    
    Call EndProc

End Sub


'*********************************
'** フルパスからファイル名とパスを取得
'*********************************
Public Sub GetFilNameAndPath(ByVal Str_FileFullPath As String, ByRef Str_FilePath As String, ByRef Str_FileName As String)
    
    If Trim(Str_FileFullPath) = "" Then
        Str_FilePath = ""
        Str_FileName = ""
        Exit Sub
    End If
    
    Str_FilePath = Left(Str_FileFullPath, InStrRev(Str_FileFullPath, "\") - 1)
    Str_FileName = Right(Str_FileFullPath, Len(Str_FileFullPath) - Len(Str_FilePath) - 1)

End Sub


'*********************************
'** 属性・桁文字列から項目桁数を返却
'*********************************
Public Function GetDigitNum(Str_PicString As String) As Integer
    
    Dim Int_KPos As Integer       '"("の出現位置
    Dim Str_DCount As String  '桁数文字列
    Dim X1 As Long
    
    'PICTURE文字列から桁数(バイト数)を取得する
    'とりあえず、9(xx),X(xx),N(XX),S9(xx),S9(xx)COMP-3を対応する
    '9(xx)V9(xx)や9(xx)V99等、小数点項目は必要であれば追加する
    GetDigitNum = 0
    Int_KPos = InStr(Str_PicString, "(")
    If Int_KPos > 0 Then
        X1 = Int_KPos + 1
        Str_DCount = ""
        Do Until Mid(Str_PicString, X1, 1) = ")"
            Str_DCount = Str_DCount & Mid(Str_PicString, X1, 1)
            X1 = X1 + 1
        Loop
        
        'N(99)は2バイト文字
        If InStr(Str_PicString, "N(") > 0 Then
            GetDigitNum = CInt(Str_DCount) * 2
            Exit Function
        End If
        
        'COMP-3指定がある場合、+1して2で割るのが計算式。端数の丸めが気になるので以下の計算とする。
        '偶数の場合+2して2で割る。奇数の場合+1して2で割る
        If InStr(Str_PicString, "COMP-3") > 0 Then
            If (CInt(Str_DCount) Mod 2) > 0 Then
                GetDigitNum = (CInt(Str_DCount) + 1) / 2
            Else
                GetDigitNum = (CInt(Str_DCount) + 2) / 2
            End If
            Exit Function
        End If
        
        'その他の場合はそのまま
        GetDigitNum = CInt(Str_DCount)
        Exit Function
    Else
        '"()"が無いPICTURE文字列「99V99」等は今回考慮しない。必要であれば追加する。
        '・・・
    End If

End Function


'*********************************
'** 桁位置再計算処理
'*********************************
'** 返却値
'**   0:正常
'**   1:REDEFINES元項目に桁位置が編集されていない
'**   2:REDEFINES定義元項目が存在しない
'*********************************
Public Function ReculcDigitPos() As Integer
        
    Dim X1 As Long  '使い捨て添え字
    Dim Lng_LastRow As Long
    
    '制御配列の初期化
    Erase CA
    
    ReculcDigitPos = 0
    
    'レコード長算出のため。最終行にFILLERを追加
    Lng_LastRow = EditSheet.Cells(1, 1).CurrentRegion.Rows.Count + 1
    '最終行に01レベルでFILLER X(01)を追加
    EditSheet.Range("A" & Lng_LastRow) = "01"
    EditSheet.Range("B" & Lng_LastRow) = "レコード長"
    EditSheet.Range("C" & Lng_LastRow) = "X(01)"
    
    '管理変数の初期化
    Idx1 = -1
    Lng_NowRow = 2
    Lng_NextDigitPos = 1
    
    Do Until Trim(EditSheet.Range("A" & Lng_NowRow).Value) = ""
        
        '*** REDEFINES項目(E列)に値が編集されている場合制御配列に登録する。
        If Trim(EditSheet.Range("E" & Lng_NowRow).Value) <> "" Then
            Idx1 = Idx1 + 1
            CA(Idx1).Str_Category = "R"
            CA(Idx1).Lng_RedefinesPos = Lng_NextDigitPos
            CA(Idx1).Int_Level = CInt(Trim(EditSheet.Range("A" & Lng_NowRow).Value))
            CA(Idx1).Lng_Row = Lng_NowRow
            
            '現在位置から上方にREDEFINES元項目名を探す。
            X1 = Lng_NowRow - 1
            Do Until X1 <= 1
                If Trim(EditSheet.Range("B" & X1).Value) = Trim(EditSheet.Range("E" & Lng_NowRow).Value) Then
                    If Trim(EditSheet.Range("F" & X1).Value) <> "" Then
                        '再定義元の桁位置を編集
                        Lng_NextDigitPos = CLng(Trim(EditSheet.Range("F" & X1).Value))
                        Exit Do
                    Else
                        '再定義元の桁位置が編集されていない（基本ありえない）
                        ReculcDigitPos = 1
                        Exit Function
                    End If
                End If
                X1 = X1 - 1
            Loop
            
            'REDEFINES元項目名が存在しない
            If X1 <= 1 Then
                ReculcDigitPos = 2
                Exit Function
            End If
        End If
        
        '*** OCCURS項目(D列)に値が編集されている場合制御配列に登録する。
        '*** ただし、OCCURS繰り返し中は登録しない。
        If Trim(EditSheet.Range("D" & Lng_NowRow).Value) <> "" Then
            '制御配列に何も登録されてない場合、登録する
            If Idx1 = -1 Then
                Idx1 = Idx1 + 1
                Call AddControlArrayForOccurs
            Else
            '制御配列に何か登録されている場合
                If CA(Idx1).Lng_Row = Lng_NowRow Then
                Else
                    Idx1 = Idx1 + 1
                    Call AddControlArrayForOccurs
                End If
            End If
        End If
        
        '*** 開始桁位置を編集する。ただし、既に編集済みの場合は編集しない。
        If Trim(EditSheet.Range("F" & Lng_NowRow).Value) = "" Then
            EditSheet.Range("F" & Lng_NowRow).Value = Lng_NextDigitPos
        End If
        
        '*** 次行桁位置を算出する
        Lng_NextDigitPos = Lng_NextDigitPos + GetDigitNum(Trim(EditSheet.Range("C" & Lng_NowRow).Value))
        
        '*** 現在行をカウントアップする
        Lng_NowRow = Lng_NowRow + 1
        
        '*** 制御配列の終了判定を行う
        Do Until False
                        
            If Idx1 < 0 Then
                Exit Do
            End If
            
            '現在のLEVEL≦制御配列(Idx1)のLEVELの場合
            If CInt(Trim(EditSheet.Range("A" & Lng_NowRow).Value)) <= CA(Idx1).Int_Level Then
                
                '区分が"R"の場合
                If CA(Idx1).Str_Category = "R" Then
                    '次行桁位置
                    Lng_NextDigitPos = CA(Idx1).Lng_RedefinesPos
                    '制御配列のクリア
                    Call ClearControlArray(Idx1)
                    Idx1 = Idx1 - 1
                Else
                '区分が"O"の場合
                    'OCCURS回数(Idx1)＞現在の繰返数(Idx1)
                    If CA(Idx1).Int_OccursNum > CA(Idx1).Int_NowOccursNum Then
                        CA(Idx1).Int_NowOccursNum = CA(Idx1).Int_NowOccursNum + 1
                        Lng_NowRow = CA(Idx1).Lng_Row
                        Exit Do
                    Else
                    'OCCURS回数(Idx1)≦現在の繰返数(Idx1)
                        '制御配列のクリア
                        Call ClearControlArray(Idx1)
                        Idx1 = Idx1 - 1
                    End If
                End If
            Else
                Exit Do
            End If
        Loop
    Loop
    
    '追加した最終行を削除
    EditSheet.Rows(Lng_LastRow & ":" & Lng_LastRow).Delete Shift:=xlUp
    EditSheet.Range("A1").Select

End Function


'*********************************
'** 制御配列のクリア
'*********************************
Public Sub ClearControlArray(Lng_Idx As Long)

    CA(Lng_Idx).Str_Category = ""
    CA(Lng_Idx).Int_Level = 0
    CA(Lng_Idx).Lng_RedefinesPos = 0
    CA(Lng_Idx).Int_OccursNum = 0
    CA(Lng_Idx).Int_NowOccursNum = 0
    CA(Lng_Idx).Lng_Row = 0

End Sub


'*********************************
'** 開始処理
'*********************************
Public Sub StartProc()
    
    Application.ScreenUpdating = False '画面描画を停止
    Application.Cursor = xlWait 'ウエイトカーソル
    Application.EnableEvents = False 'イベントを抑止
    Application.DisplayAlerts = False '確認メッセージを抑止
    Application.Calculation = xlCalculationManual '計算を手動に

End Sub


'*********************************
'** 終了処理
'*********************************
Public Sub EndProc()
    
    Application.StatusBar = False 'ステータスバーを消す
    Application.Calculation = xlCalculationAutomatic '計算を自動に
    Application.DisplayAlerts = True '確認メッセージを開始
    Application.EnableEvents = True 'イベントを開始
    Application.Cursor = xlDefault '標準カーソル
    Application.ScreenUpdating = True '画面描画を開始

End Sub


'*********************************
'** OCCURSのための制御配列追加
'*********************************
Public Sub AddControlArrayForOccurs()
                
    CA(Idx1).Str_Category = "O"
    CA(Idx1).Int_Level = CInt(Trim(EditSheet.Range("A" & Lng_NowRow).Value))
    CA(Idx1).Int_OccursNum = CInt(Trim(EditSheet.Range("D" & Lng_NowRow).Value))
    CA(Idx1).Int_NowOccursNum = 1
    CA(Idx1).Lng_Row = Lng_NowRow

End Sub

今回のポイントとなる処理

今回の桁位置計算のメイン処理は「ReculcDigitPos」である。その中でも「制御配列の終了判定を行う」部分がポイントだ。ここがミスると桁位置計算が狂う。

・・・
        '*** 制御配列の終了判定を行う
        Do Until False
                        
            If Idx1 < 0 Then
                Exit Do
            End If
            
            '現在のLEVEL≦制御配列(Idx1)のLEVELの場合
            If CInt(Trim(EditSheet.Range("A" & Lng_NowRow).Value)) <= CA(Idx1).Int_Level Then
                
                '区分が"R"の場合
                If CA(Idx1).Str_Category = "R" Then
                    '次行桁位置
                    Lng_NextDigitPos = CA(Idx1).Lng_RedefinesPos
                    '制御配列のクリア
                    Call ClearControlArray(Idx1)
                    Idx1 = Idx1 - 1
                Else
                '区分が"O"の場合
                    'OCCURS回数(Idx1)＞現在の繰返数(Idx1)
                    If CA(Idx1).Int_OccursNum > CA(Idx1).Int_NowOccursNum Then
                        CA(Idx1).Int_NowOccursNum = CA(Idx1).Int_NowOccursNum + 1
                        Lng_NowRow = CA(Idx1).Lng_Row
                        Exit Do
                    Else
                    'OCCURS回数(Idx1)≦現在の繰返数(Idx1)
                        '制御配列のクリア
                        Call ClearControlArray(Idx1)
                        Idx1 = Idx1 - 1
                    End If
                End If
            Else
                Exit Do
            End If
        Loop
・・・

まとめ

私は、メインの仕事は汎用機COBOLシステムのSEであり、必要に迫られて独学でExcel VBAで作っているため、VBやVBAを専門にしている人から見ると色々と指摘したくなるのでは？とは思う。
ただ、本質はそんなところにはなく、「ロジックを作成する面白さ」が体験できることなのではないだろうか。

仕事の内容によっては、ロジックのコーディングはAIに任せて自分は適切に支持を出す「プロンプトエンジニア（最近知った言葉）」もすごい仕事だと思う。昨年の春から社会人になったウチの次男がまさにそんな仕事をする職場のようで、先日帰省してきた時に話をしたところ「もう自分でロジックを考える時間がない。公・私両方でAIを駆使して仕事に取り組まないと捌けない。」と言っていた。帰省した時にウチにあったPCで、次男が自分で立ち上げた英会話勉強用のサイトを実演して見せてくれた。あっと言う間にWEBサイトが作成され、スマホからAI相手の英会話ができるようになったのだが、さっぱり意味が解らなかった．．．

そういう種類の仕事をしている人はAIの勉強が自分の成果に直接つながるので、頑張って学習して習得してほしい。そうではなく、純粋にロジックやアルゴリズムを考えるの好きな人は、AIに頼らずに是非自分でロジックを構築しコードを書いてみてほしい。それが、自分の本職を助けてくれるものであるならば、これほどやりがいのあることはない。