シーゴの Excel 研究室

タイトル変更しました (旧称:今日を乗り切るExcel研究所)

【VBA】固定長テキスト形式でデータを保存したい【100本ノック】

今回も今さらですがエクセルの神髄様の Twitter 企画 「VBA100本ノック」の 65 本目を取り上げます。

お題:VBA100本ノック 65本目:固定長テキスト出力

問題ページ

方針

固定長テキストとはこれまたシブい課題です。

しかも半角カナとかもう、知らない世代の方が多いでしょう。

先輩技術者の昔語りでたまに聞く「電文」とかいうのがこれでしょうか。

今回「全銀フォーマット」というのを調べると銀行系では今でも普通に使われているようです。

プログラミングとして一度は経験しておいた方がいいレガシーな課題ということで、貴重な機会を与えてくれる良問に感謝です。

さて Excel が固定長テキストをデータ取り込みのファイル形式としてサポートしていることは、「テキストファイルウィザード」などでよく知られるところです。

ということは当然、固定長テキストデータで書き出す方法もどこかにあるはずです。 そのセンを探ってみることにします。

解答

【修正 2021/09/14】保存先が不正であったバグを修正しました。データの Excel ファイルと同じフォルダに出力ファイルが保存されます。OneDrive 上のファイルでも問題ないはずです。

Option Explicit

Private Enum フォーマット
    項目名 = 1
    文字形態
    桁数
End Enum

Sub VBA100_65()
    Application.ScreenUpdating = False

    Dim wb As Workbook
    Set wb = ActiveWorkbook
    
    Dim spec As Range
    Set spec = wb.Worksheets("フォーマット").UsedRange

    Worksheets("data").Copy

    With ActiveSheet
        .Rows(1).Delete
        Dim i As Long
        For i = 2 To spec.Rows.Count
            .Columns(i - 1).ColumnWidth = spec.Cells(i, 桁数).Value
            If spec.Cells(i, 文字形態).Value = "N" Then
                .Columns(i - 1).NumberFormat = String(spec.Cells(i, 桁数).Value, "0")
            End If
        Next
    End With

    Application.DisplayAlerts = False
    With ActiveWorkbook
        .SaveAs Filename:=wb.Path & "/data.txt", FileFormat:=xlTextPrinter
        .Close
    End With
    Application.DisplayAlerts = True
    
    Application.ScreenUpdating = True
End Sub

出力結果

20001ミズホ 001ホンテン 20000123ヤマダ タロウ 0000001234 20001ミズホ 560インタ-ネツト 11234567ススギ イチロウ 0007654321 20005ミツビシユ-エフジエイ 325ギンザ 11111111ヒラダイラ ヘツペイ 0000555555

 



 

考察

次の2つの方法が考えられます。

  1. PRN 形式で保存する
  2. Format 関数を使う

上記解答は「1. PRN 形式で保存する」の例です。 「2. Format 関数を使う」の解答プログラムは本記事の最後に掲載します。

1. PRN 形式で保存する

Excel の「名前を付けて保存」(F12) で選択できるファイルの種類をながめると「テキスト(スペース区切り)(*.prn)」というのがあります。

f:id:shego:20210912012604p:plain

PRN というのはプリンター出力用のファイル形式で、本来バイナリファイルだったような気がするのですが、なぜか Excel では「プリンター テキスト(xlTextPrinter)」という扱いになっています。

実際に Excel シートを PRN で保存してみると、確かに空白文字で桁合わせされた固定長テキストレコードとしてデータが保存されます。

各フィールドの固定長はどこで定義されるのでしょうか。

この固定長の文字数にはワークシート上の列幅が反映されています。

もともと「列の幅」に指定する数値は「0」の文字数換算なので、ここに PRN フィールドの固定文字数(半角)そのものを指定すればいいことになります。

f:id:shego:20210912015505p:plain

各フィールド出力は、数値が右寄せ、文字列が左寄せで半角スペース詰めされます。

数値を 0 詰めするには、列に対して「セルの書式設定」(Ctrl+1) の「表示形式」で 0 を桁数並べたフォーマットを指定します。

フィールド長を超えるデータが入っていた場合、文字列は右端で切り詰められますが、数値は「####」のようなエラー文字列が入ります。

うれしいのは、日本語の2バイト文字を含むデータがあっても破綻しないことです。 シフトJISの全角を2文字として数え、末端の境界にかかっても壊れずに適切に処理してくれます。

一方、PRN には致命的な欠点もあります。

各フィールド文字数を合計した1レコードの文字列長が 240 文字に制限されているのです。

240 文字を超えたレコード行は折り返されます。

またこの折り返しというのが、行(レコード)ごとではなく、全行分の折り返しがファイルの後ろに追加されるというものなので、後工程で復元するとしても面倒です。

これらの仕様はおそらく昔のインパクトプリンターの動作方式の名残りなのでしょう。

240 文字以下なら問題ないのですが現実データとしては微妙な長さで採用に悩むところです。

PRN 保存を使わないとなると、行データを地道に変換してテキストファイルに書き出すしかありません。

2. Format 関数を使う

数値や文字列を固定長テキストとしてフォーマットするには Format 関数を使います。

Format 関数は数値、日時、文字列などの値を書式化する関数で、書式を指定する式の文法はセルの「表示形式」とほぼ同様です。

数値データを 0 詰めの固定長にするには、「0」 を桁数分だけ並べてた書式を指定します。 数値は右寄せで埋められます。

    ' 右寄せ 0 詰め 6 桁数字
    field = Format(123, "000000")  ' ⇒ "000123"

文字列データを固定長にするには、書式に「@」を文字数分だけ並べます。 左寄せの指定には先頭に「!」を付ければ、右側に半角スペースで固定長の桁数が確保されます。

    ' 左寄せ空白詰め10桁半角文字
    field = Format("Hello", "!@@@@@@@@@@")  ' ⇒ "Hello     "

これはセルの表示形式にはない仕様です。

また指定桁数より長い文字列が与えられたときの挙動には注意が必要です。 左寄せ文字列は左から切り詰められる仕様になっています。

    field = Format("abcdef", "!@@@")  ' ⇒ "def"   ' 左から切り詰められる

ところで、通常、電文フォーマットが要求する固定長とは文字数ではなくバイト数、すなわち半角文字単位での桁数でしょう。

Format 関数で指定できるのは文字数であり、半角桁数ではありません。 つまりシフトJISで出力する限り、1バイト文字である半角の英数記号と半角カタカナのデータでしか通用しません。

シフトJISの全角文字(2バイト)も固定長バイトで出力可能とするには、Format 関数を使わずに自前で文字幅を数えるしかなさそうです。

' 半角桁数で左寄せ空白詰め
Function rPad(str As String, width As Integer, Optional pad As String = " ") As String
    Dim leftStr As String
    Dim byteLen As Long
    Dim i As Integer
    For i = Len(str) To 0 Step -1
        leftStr = Left(str, i)
        byteLen = LenB(StrConv(leftStr, vbFromUnicode))
        If byteLen <= width Then Exit For
    Next
    rPad = leftStr & String(width - byteLen, pad)
End Function

Format 関数を使った解答の実装例も参考まで以下に掲載しておきます。

 



 

Option Explicit

Private Enum レコード仕様
    項目名 = 1
    文字形態
    桁数
End Enum

Private Type RecordFormat
    ' part As String
    fieldFormats() As String
    lineLength As Long
End Type

Sub VBA100_65_ex2()
    On Error GoTo final

    Dim dataRecFmt As RecordFormat
    dataRecFmt = createRecordFormat(Worksheets("フォーマット"))
    
    Dim data As Range
    Set data = Worksheets("data").UsedRange
    Set data = Intersect(data, data.Offset(1))
    
    Open ActiveWorkbook.Path & "\data.txt" For Output As #1 ' OneDriveでは開けない!
    
    Dim rec As Range
    For Each rec In data.Rows
        Print #1, recordToText(rec, dataRecFmt)
    Next

final:
    Close #1
    If Err.Number <> 0 Then MsgBox Err.Description
End Sub

Private Function createRecordFormat(specSheet As Worksheet) As RecordFormat
    Dim flds As Range
    Set flds = specSheet.Range("A1").CurrentRegion
    Set flds = Intersect(flds, flds.Offset(1)).Rows
    
    ReDim createRecordFormat.fieldFormats(1 To flds.Count)
    Dim i As Integer
    For i = 1 To flds.Count
        createRecordFormat.fieldFormats(i) = fieldFormat(flds(i))
    Next
    
    createRecordFormat.lineLength = WorksheetFunction.Sum(flds.Columns(桁数))
End Function

Private Function fieldFormat(ByVal fld As Range) As String
    Set fld = fld.Cells
    Select Case fld(文字形態)
        Case "N"
            fieldFormat = String(fld(桁数), "0")
        Case "C"
            fieldFormat = "!" & String(fld(桁数), "@")
        Case Else
            Err.Raise 9999, , "不正文字形態:" & fld(文字形態)
    End Select
End Function

Private Function recordToText(rec As Range, recFmt As RecordFormat) As String
    Dim vals() As Variant
    vals = rowToArray(rec)
    
    Dim i As Integer
    For i = 1 To UBound(vals)
        vals(i) = Format(vals(i), recFmt.fieldFormats(i))
    Next
    recordToText = Join(vals, "")
    
    If recFmt.lineLength <> stringWidth(recordToText) Then
        Err.Raise 9999, , "不正データ:sheet=" & rec.Worksheet.Name & ", row=" & rec.Row
    End If
End Function

Private Function stringWidth(str As String) As Long
    stringWidth = LenB(StrConv(str, vbFromUnicode))
End Function

Private Function rowToArray(rng As Range) As Variant()
    rowToArray = WorksheetFunction.Transpose(WorksheetFunction.Transpose(rng.Rows(1)))
End Function