| |
こんな方法も有ります
基本的に文字数を勘定する方式を取ります
出力する、フィールドのバイト長等を設定するシートを作り、このシートの設定に従い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
'１行分のDataをシートから読みこむ
vntField = Range(.Offset(i), _
.Offset(i, lngColEnd - 1)).Value
'出力１レコード作成
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
'１レコード書き出し
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が長い場合、２バイト文字の処理を行います
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
|
|
Hirofumi
- 05/5/19(木) 18:43 -
