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

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

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

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

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

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

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

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

/*
 * 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
'--------------------------------------

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

元データです



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





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



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



文字列にして、



取り込み、、、完了。



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


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




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

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









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



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

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



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



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

---

VBA系の無料メルマガ書いてます
メルマガ『ＶＢＡで楽しくプログラミング』(無料) を購読しませんか？
	E-mail

---

...

---

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

ＶＢＡで楽しくプログラミング	最新情報	掲示板	バックナンバー	メルマガ登録と解除
コンビニのオモテとウラ話	最新情報	掲示板	バックナンバー	メルマガ登録と解除
ＡＳＰで遊ぶ、失敗する	最新情報	掲示板	バックナンバー	メルマガ登録と解除
AB型三流ＰＧ 業務のグチ	最新情報	掲示板	バックナンバー	メルマガ登録と解除
初心者にやさしいプログラム	最新情報	掲示板	バックナンバー	メルマガ登録と解除
ネットで稼ぐ本音と失敗談	最新情報	掲示板	バックナンバー
www.ken3.org(サイト内)から を利用して、 を