Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


56397 / 76732 ←次へ | 前へ→

【25088】Re:固定長データへの出力
回答  Hirofumi  - 05/5/19(木) 18:43 -

引用なし
パスワード
   こんな方法も有ります
基本的に文字数を勘定する方式を取ります
出力する、フィールドのバイト長等を設定するシートを作り、このシートの設定に従いTextを出力します
また、コードは、標準モジュールが、VBEの「挿入」→「標準モジュール(M)」で追加されますので
この標準モジュールに記述して下さい(コピペ)

次に「書込設定」と言う名前の、WorkSheetを作り、
このシートに設定したバイト数、列見出し、書式、Fillerを使用してファイルを書込みます
WorkSheets("書込設定")の、B1から、C1、D1・・・と列見出しと成る文字列をセルに書き込みます
同じく、B2、C2、D2・・・と、ファイールドのバイト長を設定します
同じく、B3、C3、D3・・・と、出力フィールドの右詰、左詰を文字で設定します
(右詰なら"R"or"r"、左詰なら"L"or"l")
同じく、WorkSheets("書込設定")のB6には、必要が有ればFillerをバイト数で設定
(Fillerは、レコード長調整用のスペース文字)
同じく、WorkSheets("書込設定")のB9には、改行コードの種類を番号で設定
(vbCrLf = 1、vbCr = 2、vbLf = 3、無し = 0)

出力データが有るWorkSheetは、Upしたコードではアクティブシートです
また、データの列数は、"書込設定"に設定した、列数を使用します

Option Explicit

Public Sub WriteFixdText()

  Dim vntFileName As Variant
  Dim wksSetUp As Worksheet
  Dim wksRead As Worksheet
  Dim lngReadRow As Long
  Dim lngReadCol As Long
  Dim strFiller As String
  Dim vntFieldLen As Variant
  Dim strRetCode As String
  
  '出力名を設定します
'  vntFileName = ThisWorkbook.Path & "\" & "TestFile.txt"
  vntFileName = "TestFile"
  '出力名を取得します
  If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
    Exit Sub
  End If
  
  'データ行の初期位置設定
  lngReadRow = 2
  'データ列の初期位置設定
  lngReadCol = 1
  '「設定」シートの参照を設定
  Set wksSetUp = ThisWorkbook.Worksheets("書込設定")
  'データの有るシートの参照を設定
  Set wksRead = ActiveSheet
  
  'フィールド特性を取得
  strRetCode = GetWriteField(vntFieldLen, strFiller, wksSetUp)
  
  'ファイルに出力
  SDFWrite vntFileName, vntFieldLen, strFiller, _
          strRetCode, wksRead, lngReadRow, lngReadCol
  
  '「設定」シートの参照を破棄
  Set wksSetUp = Nothing
  '読み込むシートの参照を破棄
  Set wksRead = Nothing
  
  Beep
  MsgBox "処理が終了しました", vbOKOnly, "終了"

End Sub

Private Sub SDFWrite(ByVal strFileName As String, _
            vntFieldLen As Variant, _
            strFiller As String, _
            strRetCode As String, _
            ByVal wksRead As Worksheet, _
            lngReadRow As Long, _
            lngReadCol As Long)

  Dim dfn As Integer
  Dim i As Long
  Dim j As Long
  Dim lngRowEnd As Long
  Dim lngColEnd As Long
  Dim strBuf As String
  Dim vntField As Variant
  
  
  '出力最終列を設定
  lngColEnd = UBound(vntFieldLen, 2)
  '出力最終行を取得
  With wksRead
    lngRowEnd = .Cells(65536, lngReadCol).End(xlUp).Row
  End With
  
  '空きファイル番号を取得します
  dfn = FreeFile
  '出力ファイルをOpenします
  Open strFileName For Output As dfn
    
  With wksRead.Cells(lngReadRow, lngReadCol)
    For i = 0 To lngRowEnd - lngReadRow
      '1行分のDataをシートから読みこむ
      vntField = Range(.Offset(i), _
                .Offset(i, lngColEnd - 1)).Value
      '出力1レコード作成
      strBuf = ""
      For j = 1 To lngColEnd
        strBuf = strBuf _
          & FieldStrings(vntFieldLen(1, j), _
                CStr(vntField(1, j)), vntFieldLen(2, j))
      Next j
      '出力レコードにFillerと改行コードを付加
      strBuf = strBuf & strFiller & strRetCode
      '1レコード書き出し
      Print #dfn, strBuf;
    Next i
  End With
  
  '出力ファイルを閉じる
  Close #dfn
  
End Sub

Private Function GetWriteField(vntField As Variant, _
              strFiller As String, _
              ByVal wksSetUp As Worksheet) As String

'  設定Field長の読み込み

  Dim i As Long
  Dim lngColEnd As Long
  Dim strRet As String
  
  With wksSetUp
    lngColEnd = .Cells(2, 256).End(xlToLeft).Column
    vntField = .Range(.Cells(2, 2), .Cells(3, lngColEnd)).Value
    strFiller = Space(Val(.Cells(6, 2).Value))
    Select Case .Cells(9, 2).Value
      Case 0
        strRet = ""
      Case 2
        strRet = vbCr
      Case 3
        strRet = vbLf
      Case Else
        strRet = vbCrLf
    End Select
  End With

  GetWriteField = strRet

End Function

Private Function FieldStrings(ByVal lngLength As Long, _
            ByVal strData As String, _
            Optional ByVal strAlign As String = "L") As String

'  Dataをフィールド長に調整

'  lngLengthはフィールドの長さを半角何文字分(バイト単位)で
'  strDataはデータを文字列の型で
'  strAlignは、右詰なら"R"、"r"で
'  左詰なら"L"、"l"で(ディフォルトは"L"、実際は、"R","r"以外なら左詰)
  
  Dim strSpace As String
  Dim i As Long
  Dim intCode As Integer
  
  If lngLength <= 0 Then
    FieldStrings = ""
    Exit Function
  End If
    
  '文字列を Unicode からシステムの既定のコード ページに変換します
  strData = StrConv(strData, vbFromUnicode)
  'フィールド長よりDataが長い場合、2バイト文字の処理を行います
  If LenB(strData) > lngLength Then
    strData = LeftB(strData, lngLength)
    intCode = Asc(Right$(StrConv(strData, vbUnicode), 1))
    If (0 <= intCode And intCode <= 7) _
        Or (11 <= intCode And intCode <= 12) _
        Or (14 <= intCode And intCode <= 31) _
        Or (127 <= intCode And intCode <= 159) _
        Or (224 <= intCode And intCode <= 255) Then
      strData = LeftB(strData, lngLength - 1)
    End If
  End If
  
  '長さ調整用のスペースを作成します
  If lngLength > LenB(strData) Then
    strSpace = StrConv(String$(lngLength _
            - LenB(strData), " "), vbFromUnicode)
    'Dataをフィールド長に調整します
    If strAlign = "R" Or strAlign = "r" Then
      strData = strSpace & strData
    Else
      strData = strData & strSpace
    End If
  End If
  
  'システムの既定のコード ページを使って文字列を Unicode に変換します
  FieldStrings = StrConv(strData, vbUnicode)
  
End Function

Private Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," & _
        "Text File (*.txt),*.txt"
  
  '既定値のファイル名を設定
  strInitialFile = vntFileName
  
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 2)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True
  
End Function
0 hits

【25061】固定長データへの出力 パズラー 05/5/19(木) 9:53 質問
【25063】Re:固定長データへの出力 ウッシ 05/5/19(木) 10:02 回答
【25065】Re:固定長データへの出力 パズラー 05/5/19(木) 10:25 質問
【25067】Re:固定長データへの出力 ウッシ 05/5/19(木) 10:36 回答
【25071】Re:固定長データへの出力 パズラー 05/5/19(木) 11:18 質問
【25073】Re:固定長データへの出力 ウッシ 05/5/19(木) 11:33 回答
【25074】Re:固定長データへの出力 パズラー 05/5/19(木) 11:46 質問
【25075】Re:固定長データへの出力 ウッシ 05/5/19(木) 11:55 回答
【25097】Re:固定長データへの出力 パズラー 05/5/20(金) 10:17 お礼
【25088】Re:固定長データへの出力 Hirofumi 05/5/19(木) 18:43 回答

56397 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free