ＣＳＶから固定長（普通の）に変換

/*
 * ４．ＣＳＶから固定長（普通の）に変換 楽して、、、
*/
ＣＳＶから固定長（普通の）に変換
かぁ、、、
Ｅｘｃｅｌの機能で、できないかなぁ、、、
チョット、やってみますか。

まず、Ｅｘｃｅｌを起動して、
ファイル開くのテキストファイル、、、

ファイル名を指定して、
おっと、次は、カンマやタブなどの区切り文字、、
を選択して、、

区切り文字の種類をカンマにレ（チェック）を付けて、

文字列にして、取り込み、、、完了。

あとは、固定長で、テキストを保存すれば、ＯＫかな。。。

あれ、、名前を付けて保存に、固定長テキストファイルが無い？？？
えっ、なんで？？？Ｅｘｃｅｌの機能にないの？
（↑、、これ、Ｋｅｎ３のマチガイかもしれないので、要調査です、、）

/*
 * 5.しかたない、、、自分で作ろう、、、
*/ 
自分で、作ることにします。
Ａｃｃｅｓｓのテーブルに入れれば、なんかできそうな気がする
けど、Ｅｘｃｅｌ ＶＢＡでカッコわるく作ります。
（とりあえず、固定で、汎用性の無いプログラムで、、、）

マクロ記録で、途中まで作ります。。。
オイオイ、そんなんで、いいの？
まぁまぁ、、、途中までは、適当に、、最後の味付けだけ、
今回は、がんばります。

ツール、マクロ記録を選択。
先ほどの手順で、テキストファイルを読み込みます。

ＡＬＴ＋Ｆ１１を押すと、
すると、下記のようなモジュールができてます。
＊あいかわらず、Ｅｘｃｅｌ君すごいような、、
　バカ正直なようなコード書いてくれます
　（ほんと、助かります、三流の私は、、、）

Sub Macro1()
'
' Macro1 Macro
'

'
    Workbooks.OpenText FileName:="D:\034\Sample.txt", StartRow:=1, DataType:= _
        xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
        Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False _
        , FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 5), Array(5, 2), _
        Array(6, 2))
End Sub

まぁ、意味わかんないけど、これで、ＣＳＶがＥｘｃｅｌになります。

あとは、このコードに肉づけして、、、

Sub Macro1()
    
    Dim strINFname  As String
    Dim strOUTFname As String
    
    Dim nYLINE As Integer
    Dim x      As Integer
    Dim OUT_FNO%
    
    Dim nOUTSIZE(10) As Integer     '１０もいらないでしょ、、、
    Dim strOUTBUF As String
    
    ' csvtotxt.xls のパスを使用して、INファイル、Outファイルの
    'ファイル名を作成する
    strINFname = ActiveWorkbook.Path & "\Sample.txt"
    strOUTFname = ActiveWorkbook.Path & "\out.txt"
    
    'お行儀良く、入力ファイルがアルか、チェックしますか、、、
    If Len(Dir(strINFname) & "") = 0 Then
        MsgBox strINFname & "ファイルが見つかれません"
        Exit Sub  'モジュールを抜ける
    End If
    
    '入力ファイルをＣＳＶで開く      ↓変数に変更
    Workbooks.OpenText FileName:=strINFname, StartRow:=1, DataType:= _
        xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
        Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False _
        , FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 5), Array(5, 2), _
        Array(6, 2))
        
    '出力テキストファイルを作成する
    'シーケンシャル ライト モードで開きます
    OUT_FNO = FreeFile
    Open strOUTFname For Output As #OUT_FNO
    
    '出力先のサイズを代入
    'サンプルデータは会員番号１（８桁）、漢字氏名（２０桁）、ローマ字
    '（１８桁）、生年月日（１０桁）、会員番号２（１０桁）、暗証番号
    '（３桁）で構成されています。
    nOUTSIZE(1) = 8
    nOUTSIZE(2) = 20
    nOUTSIZE(3) = 18
    nOUTSIZE(4) = 10
    nOUTSIZE(5) = 10
    nOUTSIZE(6) = 3
    
    'データが無くなるまでループ（Ａ列が空白になるまで）
    'おいおい、データが１行しかなかったら、どうなるの？＜＜＜知らない、、
    nYLINE = 2   'タイトルを抜かし、２行目から、スタート
    While Len(Cells(nYLINE, 1) & "") <> 0
        For x = 1 To 6 'AからF列まで処理
            strOUTBUF = LeftB(Cells(nYLINE, x), nOUTSIZE(x))
            Print #OUT_FNO, strOUTBUF; '←を付けると改行されない
        Next x
        Print #OUT_FNO, ""     '改行のみする
        nYLINE = nYLINE + 1  '忘れないようにカウントアップ
    Wend
    
    Close #OUT_FNO                  ' ファイルを閉じます。

    '結果をメモ帳表示
    Shell "notepad.exe " & strOUTFname, vbNormalFocus
        
End Sub


こんな感じで、、、、

あれ、、、うまく行かない、、、
今日は、あきらめます（すみません）
strOUTBUF = LeftB(Cells(nYLINE, x), nOUTSIZE(x))
これが、おかしいみたいですが、、、

私なりの答え（再度の味付け）を下記に記載します。
＊まだ、変換サイズなどを外部に出すなど、してませんが、、
'--------
Sub TEST_MAIN()

    Dim strINFname  As String
    Dim strOUTFname As String

    ' csvtotxt.xls のパスを使用して、INファイル、Outファイルの
    'ファイル名を作成する
    strINFname = ActiveWorkbook.Path & "\Sample.txt"
    strOUTFname = ActiveWorkbook.Path & "\out.txt"
    
    'お行儀良く、入力ファイルがアルか、チェックしますか、、、
    If Len(Dir(strINFname) & "") = 0 Then
        MsgBox strINFname & "ファイルが見つかれません"
        Exit Sub  'モジュールを抜ける
    End If

    'サンプルモジュールをコールする
    Call Excel97_CSVtoTXT(strINFname, strOUTFname)

    '結果をメモ帳表示
    Shell "notepad.exe " & strOUTFname, vbNormalFocus

End Sub

'サンプルモジュール
'固定処理が多いので流用・汎用性が無い、なぁ。。
'サイズを（も）引数で渡したり、工夫しないと、、
Sub Excel97_CSVtoTXT(strINFname As String, strOUTFname As String)
    
    Dim nYLINE As Integer
    Dim x      As Integer
    Dim OUT_FNO%
    
    Dim nOUTSIZE(10) As Integer     '１０もいらないでしょ、、、
    Dim strOUTBUF As String
    
    '入力ファイルをＣＳＶで開く      ↓変数に変更
    Workbooks.OpenText FileName:=strINFname, StartRow:=1, DataType:= _
        xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
        Tab:=False, Semicolon:=False, Comma:=True, Space:=False, Other:=False _
        , FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), _
        Array(6, 2))
        
    '出力テキストファイルを作成する
    'シーケンシャル ライト モードで開きます
    OUT_FNO = FreeFile
    Open strOUTFname For Output As #OUT_FNO
    
    '出力先のサイズを代入
    'サンプルデータは会員番号１（８桁）、漢字氏名（２０桁）、ローマ字
    '（１８桁）、生年月日（１０桁）、会員番号２（１０桁）、暗証番号
    '（３桁）で構成されています。
    nOUTSIZE(1) = 8
    nOUTSIZE(2) = 20
    nOUTSIZE(3) = 18
    nOUTSIZE(4) = 10
    nOUTSIZE(5) = 10
    nOUTSIZE(6) = 3
    
    'データが無くなるまでループ（Ａ列が空白になるまで）
    'おいおい、データが１行しかなかったら、どうなるの？＜＜＜知らない、、
    nYLINE = 2   'タイトルを抜かし、２行目から、スタート
    While Len(Cells(nYLINE, 1) & "") <> 0
        For x = 1 To 6 'AからF列まで処理
            strOUTBUF = Cells(nYLINE, x)
            'XXバイトに満たない場合、空白を後ろに詰めています
            strOUTBUF = LeftB(StrConv(strOUTBUF & Space(nOUTSIZE(x)), vbFromUnicode), nOUTSIZE(x))
            strOUTBUF = StrConv(strOUTBUF, vbUnicode)
            'データ書きこみ
            Print #OUT_FNO, strOUTBUF; '←を付けると改行されない
        Next x
        Print #OUT_FNO, ""     '改行のみする
        nYLINE = nYLINE + 1  '忘れないようにカウントアップ
    Wend
    
    Close #OUT_FNO                  ' ファイルを閉じます。

End Sub
'--------
こんな感じです。

/*
 * ３．読者より、アドバイス 自作関数作ってみました
*/
無いものは、自分で作ろうって、こころ、忘れてた、、、
読者からいただいた、固定長、右スペース埋め関数です。。
'----------------------------------------
Public Function SetKoteicho(input_str As String, length As Integer) As String
    Dim check_char As Integer       'Asc関数で全角かどうか調べる文字の位置
    Dim sjis_length As Integer      'シフトJIS換算の文字数
    Dim sjis_code As Integer        '文字コード(シフトJIS)
    Dim output_str As String        '固定長に変換した文字列
    sjis_length = 0
    check_char = 1
    Do
        sjis_code = Asc(Mid(input_str, check_char, 1))
        '文字コードから全角文字か半角文字かを調べる
        If sjis_code > 256 Or sjis_code < 0 Then
            '全角文字
            sjis_length = sjis_length + 2
        Else
            '半角文字
            sjis_length = sjis_length + 1
        End If
        check_char = check_char + 1
    Loop While (check_char <= Len(input_str))
    
    '必要なだけスペースを加える
    output_str = input_str & Space$(length - sjis_length)
    
    SetKoteicho = output_str
End Function
'--------------------------------------

'下記のようにコールすると、使用できます
        For x = 1 To 6 'AからF列まで処理
            '感謝して、関数を使用する、、、
            strOUTBUF = SetKoteicho(Cells(nYLINE, x), nOUTSIZE(x))
　　　　　　'-----------↑^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
            Print #OUT_FNO, strOUTBUF; '←を付けると改行されない
        Next x
'--------------------------------------

ありがたいですね、、、ホント。

元データです



まず、Ｅｘｃｅｌを起動して、
ファイル開くのテキストファイル、、、





ファイル名を指定して、
おっと、次は、カンマやタブなどの区切り文字、、
を選択して、、



区切り文字の種類をカンマにレ（チェック）を付けて、



文字列にして、



取り込み、、、完了。



あとは、固定長で、テキストを保存すれば、ＯＫかな。。。


あれ、、名前を付けて保存に、固定長テキストファイルが無い？？？
えっ、なんで？？？Ｅｘｃｅｌの機能にないの？
（↑、、これ、Ｋｅｎ３のマチガイかもしれないので、要調査です、、）




マクロ記録で、途中まで作ります。。。
オイオイ、そんなんで、いいの？
まぁまぁ、、、途中までは、適当に、、最後の味付けだけ、
今回は、がんばります。

ツール、マクロ記録を選択。
先ほどの手順で、テキストファイルを読み込みます。









ＡＬＴ＋Ｆ１１を押すと、
すると、下記のようなモジュールができてます。
＊あいかわらず、Ｅｘｃｅｌ君すごいような、、
　バカ正直なようなコード書いてくれます
　（ほんと、助かります、三流の私は、、、）



作成したマクロをボタンへ登録、、する方法

まず、ツールバー、フォームを表示します



次に、ボタンを選択します



シートにボタンを貼ると、登録マクロが選択できます

質問や要望など連絡方法でお互い確認が取りやすく、便利なのが掲示板なのですが、私の対応のまずさから不定期で荒れてしまい、掲示板は現在封鎖中です。(反省しなきゃ)

感想や質問・要望・苦情など 三流君へメッセージを送る。 時間的余裕のある要望・質問・苦情の場合は、下記のフォームからメッセージを送ることができます。 あなたのお名前（ニックネーム）:さん 返信は？: 不用(HP更新を待つ) , E-mail→ アドレス:に返事をもらいたい ここに 感想や質問・要望・苦情など 三流君へ送るメッセージを 気軽に書いてください (感想や質問・要望・苦情はHPで記事に載せることがあります。)

急ぎで連絡がほしい、そんな時は:[三流君連絡先]に連絡してください。

番外編 愚痴系で書いてた今日の一品 (短いサブ関数など)