Excel VBA質問箱 IV

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

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


46258 / 76732 ←次へ | 前へ→

【35448】Re:テキストの読み込みについて
回答  Hirofumi  - 06/3/5(日) 0:04 -

引用なし
パスワード
   こんなやり方も有ります
長すぎるので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
6 hits

【35433】テキストの読み込みについて ちび 06/3/4(土) 16:31 質問
【35446】Re:テキストの読み込みについて ponpon 06/3/4(土) 23:02 発言
【35450】Re:テキストの読み込みについて ちび 06/3/5(日) 0:13 お礼
【35448】Re:テキストの読み込みについて Hirofumi 06/3/5(日) 0:04 回答
【35449】Re:テキストの読み込みについて Hirofumi 06/3/5(日) 0:05 回答
【35451】Re:テキストの読み込みについて ちび 06/3/5(日) 0:24 お礼

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