https://www.limecode.jp/entry/fungo/065-export-fixed-width-text

Excel&VBA解説サイト「エクセルの神髄」様出題の問題集、
「VBA100本ノック」に対する私の回答と解説のページです。

100本ノックの出題リストはこちらから
excel-ubara.com

出題：固定長テキスト出力

#VBA100本ノック 65本目
固定長データの出力です。
「フォーマット」シートに従い、2行目以降をテキスト出力してください。
文字形態は、N:右詰め0埋め、C:左詰め半角スペース埋め。
項目間区切りなしで連続で出力
※シートは任意
※本題ではないので出力ファイル及び文字コードは任意

元データ
出力フォーマット
出力テキスト

◇ 出題ページはこちら

ソースコード

定義モジュール

Option Explicit

' data
Public Const R1stdata = 2
Public Const C1stdata = 1
Public Enum CNodata
    データ区分 = C1stdata
    金融機関番号
    金融機関名
    支店番号
    支店名
    預金種目
    口座番号
    受取人氏名
    振込金額
End Enum
Public Const CLastdata = CNodata.振込金額

' フォーマット
Public Const R1stフォーマット = 2
Public Const C1stフォーマット = 1
Public Enum CNoフォーマット
    項目名 = C1stフォーマット
    文字形態
    桁数
End Enum
Public Const CLastフォーマット = CNoフォーマット.桁数

メインモジュール

Option Explicit

' 100本ノック065：固定長テキスト出力
Sub dataシートを固定長テキストに出力する()
    
    ' フォーマットを逐一呼び出せるようDictionaryにSet
    Dim Dic文字形態 As New Dictionary
    Set Dic文字形態 = Key範囲とItem範囲をDictionaryに変換 _
        (GetRange指定列のデータ部分(WSフォーマット, CNoフォーマット.項目名) _
       , GetRange指定列のデータ部分(WSフォーマット, CNoフォーマット.文字形態))
       
    Dim Dic桁数 As New Dictionary
    Set Dic桁数 = Key範囲とItem範囲をDictionaryに変換 _
        (GetRange指定列のデータ部分(WSフォーマット, CNoフォーマット.項目名) _
       , GetRange指定列のデータ部分(WSフォーマット, CNoフォーマット.桁数))
    
    ' 出力txtファイルをSet
    Dim Path出力ファイル As String
    Path出力ファイル = ThisWorkbook.Path & "\data.txt"
    
    Dim txtS出力テキスト As TextStream
    Set txtS出力テキスト = FSO.CreateTextFile(Path出力ファイル, True)
    
    ' dataシートのすべての行をループ
    Dim R As Long
    For R = R1stdata To Get最終行(WSdata)
        
        Dim text各行 As String: text各行 = ""
        
        ' detaシートのすべての列をループ
        Dim C As Long
        For C = C1stdata To Get最終列(WSdata)
            
            Dim セル値 As String: セル値 = WSdata.Cells(R, C).Value
            Dim 項目名 As String: 項目名 = WSdata.Cells(1, C).Value
            
            ' セル値を形態・桁数に応じて0/空白埋めして結合
            Select Case Dic文字形態(項目名)
            Case "N"
                text各行 = text各行 & Right(String(Dic桁数(項目名), "0") & セル値, Dic桁数(項目名))
            Case "C"
                text各行 = text各行 & Left(セル値 & String(Dic桁数(項目名), " "), Dic桁数(項目名))
            End Select
            
        Next
        
        ' txtファイルへ書き出し
        txtS出力テキスト.WriteLine text各行
        
    Next
    
    ' Streamオブジェクトを閉じてメモ帳(既定)を開く
    txtS出力テキスト.Close
    CreateObject("Wscript.Shell").Run Path出力ファイル
    
End Sub

汎用関数モジュール

Option Explicit

' FileSystemObjectの短縮取得
' 参考：https://www.limecode.jp/entry/utility/shortcall-filesystemobject
Public FSO As New FileSystemObject

' Key/Item範囲 → Dictionary
' ◆ ブログ未掲載
Function Key範囲とItem範囲をDictionaryに変換(Key範囲 As Range, Item範囲 As Range) As Dictionary

    Dim Dic結果 As New Dictionary

    Dim i As Long
    For i = 1 To Key範囲.Cells.Count
        If Dic結果.Exists(Key範囲.Cells(i).Value) = False Then
            Dic結果.Add Key範囲.Cells(i).Value, Item範囲.Cells(i).Value
        End If
    Next
    
    Set Key範囲とItem範囲をDictionaryに変換 = Dic結果

End Function

' 最終行の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終行(指定オブジェクト As Variant, Optional ByVal C As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終行を取得
    Get最終行 = 対象セル範囲.Rows.Count + 対象セル範囲.Row - 1

    ' 列が指定されていればその列の入力最終行を取得
    If C <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(Get最終行, C) = ""
            Get最終行 = Get最終行 - 1
            If Get最終行 < 対象セル範囲.Row Then
                Get最終行 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 最終列の取得
' 参考：https://www.limecode.jp/entry/library/get-lastrow-lastcolumn
Function Get最終列(指定オブジェクト As Variant, Optional ByVal R As Long = -1) As Long

    ' 渡されたオブジェクトからセル範囲を取得
    Dim 対象セル範囲 As Range
    Select Case TypeName(指定オブジェクト)
    Case "Range"
        If 指定オブジェクト.Cells.CountLarge = 1 Then ' 単独セルにはCurrentRegionを取る
            Set 対象セル範囲 = 指定オブジェクト.CurrentRegion
        Else
            Set 対象セル範囲 = 指定オブジェクト
        End If
    Case "Worksheet"
        Set 対象セル範囲 = 指定オブジェクト.UsedRange
    Case "AutoFilter", "ListObject"
        Set 対象セル範囲 = 指定オブジェクト.Range
    Case Else
        Err.Raise 1000, , "対象外のオブジェクト「" & TypeName(指定オブジェクト) & "」が指定されました。"
    End Select

    ' エリアの最終列を取得
    Get最終列 = 対象セル範囲.Columns.Count + 対象セル範囲.Column - 1

    ' 列が指定されていればその列の入力最終行を取得
    If R <> -1 Then
        Do While 対象セル範囲.Worksheet.Cells(R, Get最終列) = ""
            Get最終列 = Get最終列 - 1
            If Get最終列 < 対象セル範囲.Column Then
                Get最終列 = 0
                Exit Function
            End If
        Loop
    End If

End Function

' 各列のデータ部分
' 参考：https://www.limecode.jp/entry/utility/get-column-data-range
Function GetRange指定列のデータ部分(対象シート As Worksheet, 対象列 As Long) As Range
    If Countデータ件数(対象シート) = 0 Then Exit Function
    Set GetRange指定列のデータ部分 = 対象シート.Cells(対象シート.AutoFilter.Range.Row + 1, 対象列) _
                                                            .Resize(Countデータ件数(対象シート))
End Function

' データ件数
' ◆ ブログ未掲載
Function Countデータ件数(対象シート As Worksheet) As Long
    If 対象シート.AutoFilterMode = False Then Exit Function
    With 対象シート.AutoFilter.Range
        Countデータ件数 = .Rows.Count + .Row - 2
    End With
End Function