Excel VBA質問箱 IV

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

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


8032 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【35433】テキストの読み込みについて
質問  ちび  - 06/3/4(土) 16:31 -

引用なし
パスワード
   こんにちは
VBA始めたばかりでまだわからないことが多い初心者ですがよろしくお願いします。
早速質問なのですが・・・
ひとつのフォルダ(仮に\text_data)の中のすべてのテキストファイルを
ひとつのエクセルファイルに読み込みたいのです。
テキストファイルごとに別のシートへ読み込みが出来ますでしょうか?
読み込む形式は「スペースによって揃えられた固定長フィールドデータ」で
列のデータ形式は「G/標準」です。

【35446】Re:テキストの読み込みについて
発言  ponpon  - 06/3/4(土) 23:02 -

引用なし
パスワード
   こんばんは。

ここが参考になると思います。
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110.html

あと「テキストファイル」で検索すると、
かなりの数ヒットします。

一応作ってみたのですが・・・・
マクロを記述したExcelファイルをtxtファイルのあるフォルダに保存して
開き直して実行してみてください。
うまくいかなかったらごめんなさい。

Sub test3()
  Dim myPath As String
  Dim myFile As String
  Dim NewSh As Worksheet
  Dim myNO As Integer
  Dim i As Long
  Dim myTxt As String
  
 
  myPath = ThisWorkbook.Path & "\"
  myFile = Dir(myPath & "*.txt")
  If myFile <> "" Then
   Do Until myFile = ""
     Set NewSh = Sheets.Add(after:=Sheets(Sheets.Count))
       NewSh.Name = Left$(myFile, Len(myFile) - 4)
     myNO = FreeFile
     With NewSh
      Open myPath & myFile _
          For Input As #myNO
   
      Do Until EOF(myNO)
        Line Input #myNO, myTxt
        i = i + 1
        .Cells(i, 1).Value = myTxt
      Loop
      Close #myNO
    End With
    myFile = Dir()
   Loop
  End If
End Sub

【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

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

引用なし
パスワード
   その2
以下を上記と別な標準モジュールに記述して下さい

Option Explicit

' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Public Function GetFolderPath(strPath As String) As Boolean

  Const BIF_RETURNONLYFSDIRS = &H1
  Const ssfDESKTOP = &H0
  Const CSIDL_WINDOWS = &H24
  
  Dim strTitle As String
  Dim objFolder As Object
  Dim hWnd As Long
  
  'アクティブなWindowのハンドルを取得
  hWnd = GetForegroundWindow
  ' 表示タイトルを指定
  strTitle = "フォルダを選択して下さい"
  ' フォルダ選択ダイアログを表示
  Set objFolder = CreateObject("Shell.Application"). _
              BrowseForFolder(hWnd, strTitle, _
                BIF_RETURNONLYFSDIRS, ssfDESKTOP)
  ' フォルダを選択したときは
  If Not (objFolder Is Nothing) Then
    ' 選択フォルダを表示
    With objFolder
      ' 親フォルダが存在するときは
      If Not (.ParentFolder Is Nothing) Then
        ' 選択フォルダのフルパスを表示
        strPath = .Items.Item.Path
      ' 親フォルダのときは
      Else
        ' フォルダ名を表示
        strPath = .Title
      End If
    End With
    ' Folderオブジェクトを破棄
    Set objFolder = Nothing
    '戻り値にTrueを設定
    GetFolderPath = True
  End If
  
  If strPath <> "" And Right(strPath, 1) <> "\" Then
    strPath = strPath & "\"
  End If

End Function

Public Function GetFilesList(vntFileNames As Variant, _
              strFilePath As String, _
              objFso As Object, _
              Optional strNamePattan As String = ".*", _
              Optional strExtePattan As String = ".*") As Boolean

  Dim i As Long
  Dim objFiles As Object
  Dim objFile As Object
  Dim regExten As Object
  Dim regName As Object
  Dim vntRead() As Variant
  Dim strName As String

  'フォルダの存在確認
  If Not objFso.FolderExists(strFilePath) Then
    GoTo Wayout
  End If

  'regExtenpのオブジェクトを取得(正規表現を作成)
  Set regExten = CreateObject("VBScript.RegExp")
  With regExten
    'パターンを設定
    .Pattern = strExtePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With
  Set regName = CreateObject("VBScript.RegExp")
  With regName
    'パターンを設定
    .Pattern = strNamePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With

  'フォルダオブジェクトを取得
  Set objFiles = objFso.GetFolder(strFilePath).Files

  'ファイルの数が0でなければ
  If objFiles.Count <> 0 Then
    For Each objFile In objFiles
      With objFile
        strName = .Path
        '検索をテスト
        If regExten.test(objFso.GetExtensionName(strName)) Then
          If regName.test(objFso.GetBaseName(strName)) Then
            i = i + 1
            ReDim Preserve vntRead(1 To i)
            vntRead(i) = strName
          End If
        End If
      End With
    Next objFile
  End If

  Set regExten = Nothing
  Set regName = Nothing

  If i <> 0 Then
    vntFileNames = vntRead
    GetFilesList = True
  End If

Wayout:

  'フォルダオブジェクトを破棄
  Set objFiles = Nothing
  Set objFile = Nothing

End Function

【35450】Re:テキストの読み込みについて
お礼  ちび  - 06/3/5(日) 0:13 -

引用なし
パスワード
   ponponさん、こんばんは。

マクロを作って下さってありがとうございます。
早速実行してみます。
教えて頂いたリンク先も見て勉強します。

ありがとうございました。

【35451】Re:テキストの読み込みについて
お礼  ちび  - 06/3/5(日) 0:24 -

引用なし
パスワード
   Hirofumiさん

すごいマクロですね!初心者の私には到底作れないレベルです...f^_^;
早速実行してみます、ありがとうございました。

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