Excel VBA質問箱 IV

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

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


47249 / 76737 ←次へ | 前へ→

【34449】Re:フォルダ内のファイル読み込み方法
回答  Hirofumi  - 06/2/2(木) 22:50 -

引用なし
パスワード
   3行ずつ読み飛ばし、4行目をのみ出力する例です
Testして居ないので上手く行かなかったらゴメン

Option Explicit

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

Public Sub CSVRead()
  
'  CSVデータの読み込み
  
  Const ForReading = 1

  Dim i As Long
  Dim lngCount As Long
  Dim rngWrite As Range
  Dim lngRow As Long
  Dim strPath As String
  Dim vntFileNames As Variant
  Dim vntField As Variant
  Dim strBuff As String
  Dim objFso As Object
  Dim objFileStr As Object
  Dim strProm As String
  
  '書き込む位置を設定
  Set rngWrite = ActiveSheet.Cells(1, "A")
  
  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
  
  '読み込むファイルのフォルダを設定
  strPath = GetFolderPath
  If strPath = "" Then
    strProm = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  '指定フォルダからファイル名を取得
  If Not GetFilesList(vntFileNames, strPath, objFso, ".*", "csv") Then
    strProm = "ファイルが有りません"
    GoTo Wayout
  End If
  
  Application.ScreenUpdating = False
  
  For i = 1 To UBound(vntFileNames)
    'カウントの初期値設定
    lngCount = 1
    '指定ファイルを読み込みモードでOpen
    Set objFileStr = objFso.OpenTextFile(vntFileNames(i), ForReading)
    With objFileStr
      Do Until .AtEndOfStream
        'ファイルから1行読み込み
        strBuff = .ReadLine
        '4行目だけ出力
        If lngCount Mod 4 = 0 Then
          If strBuff <> "" Then
            'CSVをフィールドに分割
            vntField = Split(strBuff, ",")
            '指定シートの指定行列位置について
            With rngWrite.Offset(lngRow)
              'フィールドの書き込み
              .Resize(, UBound(vntField) + 1).Value = vntField
            End With
            '書き込み行位置を更新
            lngRow = lngRow + 1
          End If
        End If
        'カウントをインクリメント
        lngCount = lngCount + 1
      Loop
      'ファイルをClose
      .Close
    End With
  Next i
  
  strProm = "処理が完了しました"
  
Wayout:
  
  Application.ScreenUpdating = True
  
  Set objFileStr = Nothing
  Set objFso = Nothing
  Set rngWrite = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

Private 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

  'FSOのオブジェクトを取得
  Set objFso = CreateObject("Scripting.FileSystemObject")
 
  'フォルダの存在確認
  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

Private Function GetFolderPath() As String

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

  GetFolderPath = strTmpPath
  
End Function
0 hits

【34383】フォルダ内のファイル読み込み方法 たく 06/2/1(水) 18:53 質問
【34397】Re:フォルダ内のファイル読み込み方法 inoue 06/2/1(水) 22:12 発言
【34402】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/1(水) 23:40 発言
【34404】Re:フォルダ内のファイル読み込み方法 inoue 06/2/2(木) 0:33 発言
【34405】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/2(木) 0:42 発言
【34406】Re:フォルダ内のファイル読み込み方法 inoue 06/2/2(木) 0:50 発言
【34407】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/2(木) 1:00 発言
【34413】Re:フォルダ内のファイル読み込み方法 inoue 06/2/2(木) 9:15 発言
【34441】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/2(木) 20:35 質問
【34446】Re:フォルダ内のファイル読み込み方法 inoue 06/2/2(木) 22:00 発言
【34447】Re:フォルダ内のファイル読み込み方法 inoue 06/2/2(木) 22:03 発言
【34448】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/2(木) 22:17 発言
【34449】Re:フォルダ内のファイル読み込み方法 Hirofumi 06/2/2(木) 22:50 回答
【34450】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/2(木) 23:01 発言
【34497】Re:フォルダ内のファイル読み込み方法 Hirofumi 06/2/3(金) 21:39 回答
【34539】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/5(日) 22:09 お礼
【34540】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/5(日) 22:20 質問
【34571】Re:フォルダ内のファイル読み込み方法 Hirofumi 06/2/6(月) 22:41 回答
【34602】Re:フォルダ内のファイル読み込み方法 yuuka 06/2/7(火) 23:16 お礼

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