| |
こんなやり方も有ります
長すぎるので2つに分けてUpします、2つのパートを別々な標準モジュールに記述して下さい
基本的には、BinaryモードでInputB関数で読み込みます
「読込設定」と言う名前の、WorkSheetを作り、
このシートに設定したバイト数、列見出し、書式、Fillerを使用してファイルを読み込みます
WorkSheets("読込設定")の、B1から、C1、D1・・・と列見出しと成る文字列をセルに書き込みます(書かなくても可)
同じく、B2、C2、D2・・・と、ファイールドのバイト長を設定します
同じく、B3、C3、D3・・・と、セルの書式を数値で設定します（1が標準、2が文字列、3が日付、設定無しの場合は標準）
同じく、WorkSheets("読込設定")のB6には、改行コードのバイト数を設定（vbCrLfなら2、改行コード無しなら0）
データが書き込まれるWorkSheetは、Upしたコードではアクティブシートです
検証不足なので上手くいかなかったらゴメン
その1
以下を標準モジュールに記述
Option Explicit
Public Sub ReadFixdText()
Dim i As Long
Dim wksSetUp As Worksheet
Dim wkbResult As Workbook
Dim wksResult As Worksheet
Dim vntFieldLen As Variant
Dim lngRecLen As Long
Dim lngLineMax As Long
Dim strFolder As String
Dim strCompe As String
Dim vntFileNames As Variant
Dim lngWriteRow As Long
Dim lngWriteCol As Long
Dim objFso As Object
Dim strProm As String
'Folder名を指定(フォルダ選択ダイアログを出すか、フォルダを直接指定するか？)
'★フォルダを直接指定する場合
' strFolder = "C:\text_data\"
'★フォルダ選択ダイアログを出す場合
If Not GetFolderPath(strFolder) Then
strProm = "マクロがキャンセルされました"
GoTo Wayout
End If
'FSOのオブジェクトを取得
Set objFso = CreateObject("Scripting.FileSystemObject")
'指定形式のファイル名を取得
' strCompe = "^[0-9][0-9][01][0-9][0-3][0-9]$|^[0-9][0-9][01][0-9][0-3][0-9]_[0-9]+$"
strCompe = ".*"
If Not GetFilesList(vntFileNames, strFolder, objFso, strCompe, "txt") Then
strProm = "ファイルが有りません"
GoTo Wayout
End If
'「設定」シートの参照を設定
Set wksSetUp = ThisWorkbook.Worksheets("読込設定")
'設定シートよりフィールド情報の読み込み
lngRecLen = GetReadField(vntFieldLen, wksSetUp)
'画面更新を停止
Application.ScreenUpdating = False
'★新規Bookを追加の場合
Set wkbResult = Workbooks.Add
'★指定したBookの場合(以下の場合は、マクロの有るBook)
' Set wkbResult = ThisWorkbook
'書き込み列の初期値を設定
lngWriteCol = 1
'取得したTextFileの読み込み
For i = 1 To UBound(vntFileNames, 1)
'書き込み行の初期値を設定
lngWriteRow = 1
'書き込むシート名の参照を設定
With wkbResult.Worksheets
Set wksResult = .Add(Before:=.Item(1))
End With
'シート名をファイル名に変更
wksResult.Name = objFso.GetBaseName(vntFileNames(i))
'列見出しの書き込み
' PutFieldNames lngWriteRow, lngWriteCol, wksSetUp, wksResult
' lngWriteRow = lngWriteRow + 1
'総行数取得
lngLineMax = FileLen(vntFileNames(i)) \ lngRecLen
'セルの書式設定
CellsFormat lngWriteRow, lngWriteCol, _
vntFieldLen, lngLineMax, wksResult
'TextFileの読み込み
SDFRead vntFileNames(i), vntFieldLen, lngRecLen, _
wksResult, lngWriteRow, lngWriteCol
Next i
strProm = "処理が終了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set objFso = Nothing
Set wksSetUp = Nothing
Set wksResult = Nothing
Set wkbResult = Nothing
MsgBox strProm, vbInformation
End Sub
Private Sub SDFRead(ByVal strFileName As String, _
vntFieldLen As Variant, _
lngRecLen As Long, _
ByVal wksWrite As Worksheet, _
Optional lngRow As Long = 2, _
Optional lngCol As Long = 1)
'lngRow = 2 : シートのデータ書き込み先頭行位置
'lngCol = 1 : シートのデータ書き込み先頭列位置
Dim dfn As Integer
Dim vntField As Variant
Dim lngNumb As Long
'設定シートよりフィールド数の取得
lngNumb = UBound(vntFieldLen, 2)
'読み込むファイルをBinaryファイルとしてOpen
dfn = FreeFile
Open strFileName For Binary Access Read As dfn
'最終バイト数まで繰り返す
Do Until LOF(dfn) <= Loc(dfn)
'フィールドData作成
vntField = SplitData(InputB(lngRecLen, #dfn), vntFieldLen)
'List書きこみ
With wksWrite.Cells(lngRow, lngCol)
.Resize(, lngNumb).Value = vntField
End With
'書き込み行の更新
lngRow = lngRow + 1
Loop
Close #dfn
End Sub
Private Function GetReadField(vntField As Variant, _
ByVal wksSetUp As Worksheet) As Long
' 設定Field長、書式の読み込み
Dim i As Long
Dim lngColEnd As Long
Dim lngLen As Long
With wksSetUp
lngColEnd = .Cells(2, 256).End(xlToLeft).Column
vntField = .Range(.Cells(2, 2), .Cells(3, lngColEnd)).Value
'レコード長の算出
lngLen = Val(.Cells(6, 2).Value)
For i = 1 To UBound(vntField, 2)
lngLen = lngLen + CLng(vntField(1, i))
Next i
End With
GetReadField = lngLen
End Function
Private Sub CellsFormat(lngRow As Long, _
lngCol As Long, _
vntFieldAtt As Variant, _
lngMaxLine As Long, _
wksWrite As Worksheet)
' セルの書式設定
Dim i As Long
With wksWrite.Cells(lngRow, lngCol)
For i = 0 To UBound(vntFieldAtt, 2) - 1
If vntFieldAtt(2, i + 1) <> "" Then
With .Offset(, i).Resize(lngMaxLine)
Select Case vntFieldAtt(2, i + 1)
Case 1
.NumberFormatLocal = "G/標準"
Case 2
.NumberFormatLocal = "@"
Case 3
.NumberFormatLocal = "yyyy/mm/dd"
End Select
End With
End If
Next i
End With
End Sub
Private Sub PutFieldNames(lngRow As Long, _
lngCol As Long, _
ByVal wksSetUp As Worksheet, _
ByVal wksWrite As Worksheet)
' 列見出しの書きこみ
Dim lngColEnd As Long
If lngRow <= 0 Then
Exit Sub
End If
With wksSetUp
lngColEnd = .Cells(1, 256).End(xlToLeft).Column
.Range(.Cells(1, 2), .Cells(1, lngColEnd)).Copy _
Destination:=wksWrite.Cells(lngRow, lngCol)
End With
End Sub
Private Function SplitData(ByVal strLine As String, _
vntLength As Variant) As Variant
' フィールドDataに分割
Dim i As Long
Dim lngPos As Long
Dim vntField As Variant
Dim intDataMax As Integer
lngPos = 1
intDataMax = UBound(vntLength, 2)
ReDim vntField(intDataMax - 1)
For i = 1 To intDataMax
'前後のスペースをデータとして扱わない場合
' vntField(i - 1) _
= Trim(StrConv(MidB(strLine, _
lngPos, CLng(vntLength(1, i))), vbUnicode))
'前後のスペースもデータとして扱う場合
vntField(i - 1) _
= StrConv(MidB(strLine, lngPos, _
CLng(vntLength(1, i))), vbUnicode)
lngPos = lngPos + CLng(vntLength(1, i))
Next i
SplitData = vntField
End Function
|
|
Hirofumi
- 06/3/5(日) 0:04 -
