Excel VBA質問箱 IV

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

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


68019 / 76734 ←次へ | 前へ→

【13262】Re:検索マクロ
回答  Hirofumi E-MAIL  - 04/4/29(木) 14:15 -

引用なし
パスワード
   こんな形で善いと思うけど?
階層の勘定の仕方が人によって違うので
このコードの場合は、
探し始めるフォルダを0、その下のフォルダを1、またその下を2と
勘定しています

Option Explicit

Sub test_2()

  Dim i As Long
  Dim strFolderPath As String
  Dim strSearchFile As String
  Dim vntFileNames As Variant
  
'  strFolderPath = "D:\mm\oo\tt\ee\" '検索ディレクトリ
  strFolderPath = ThisWorkbook.Path
'  strSearchFile = CStr(Cells(1, 1)) & "*" 'ファイル名(セルの値)
  strSearchFile = CStr(Cells(1, 1)) & "*.xls" 'ファイル名(セルの値)

  vntFileNames = FilesList(strFolderPath, strSearchFile, 3)
    
  If vntFileNames(0) <> "" Then
    For i = 0 To UBound(vntFileNames)
      Workbooks.Open FileName:=vntFileNames(i)
    Next i
  Else
    MsgBox "ファイルが見つかりません。"
  End If

End Sub

Public Function FilesList(ByVal strFolderPath As String, _
            ByVal strSearchFile As String, _
            Optional lngSubDir As Long = -1) As Variant

  'lngSubDirの値:探し始めのフォルダ=0、その下=1・・
  
  Dim i As Long
  Dim j As Long
  Dim strFolders() As String
  Dim strFileName As String
  Dim strFileNames() As String
  
  'パスの最後に\を付加
  If Right(strFolderPath, 1) <> "\" Then
    strFolderPath = strFolderPath & "\"
  End If
    
  'フォルダのListを作成
  ReDim strFolders(0)
  '探し始めるフォルダを代入
  strFolders(0) = strFolderPath
  'フォルダをリストアップ
  If lngSubDir <> 0 Then
    ListingFolders strFolderPath, strFolders(), _
            UBound(strFolders) + 1, lngSubDir
  End If
  
  j = 0
  ReDim strFileNames(j)
  For i = 0 To UBound(strFolders)
    'ディレクトリ内の全ての標準ファイルを列挙
    strFileName = Dir(strFolders(i) & strSearchFile)
    Do Until strFileName = ""
      ReDim Preserve strFileNames(j)
      strFileNames(j) = strFolders(i) & strFileName
      j = j + 1
      strFileName = Dir
    Loop
  Next i
    
  FilesList = strFileNames()
  
End Function

Private Sub ListingFolders(ByVal strFilesPath As String, _
              strDirList() As String, _
              lngNextData As Long, _
              lngSubDir As Long)

  Dim i As Long
  Dim j As Long
  Dim lngNow As Long
  Dim strFileName As String

  '結果用配列の書き込み位置を取得
  i = lngNextData
  
  'サブディレクトリの結果リストと、一時的なリストを作成
  strFileName = Dir(strFilesPath, vbDirectory)
  Do Until strFileName = ""
    '現在のディレクトリと親ディレクトリを無視
    If strFileName <> "." And strFileName <> ".." Then
      'ディレクトリ以外を無視
      If GetAttr(strFilesPath & strFileName) _
                    And vbDirectory Then
        ReDim Preserve strDirList(i)
        '結果リストに追加
        strDirList(i) = strFilesPath & strFileName & "\"
        i = i + 1
      End If
    End If
    strFileName = Dir
  Loop
  
  j = lngNextData
  lngNextData = i
  'ディレクトリの階層を一つ下げる
  lngSubDir = lngSubDir - 1
  
  '指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
  If lngSubDir > 0 Or lngSubDir < 0 Then
    '各ディレクトリを再帰的に処理
    For i = j To lngNextData - 1
      lngNow = lngSubDir
      ListingFolders strDirList(i), strDirList(), _
                      lngNextData, lngNow
    Next i
  End If

End Sub
3 hits

【13218】検索マクロ まみ 04/4/28(水) 9:46 質問
【13231】Re:検索マクロ Jaka 04/4/28(水) 14:56 回答
【13255】Re:検索マクロ ichinose 04/4/28(水) 23:57 回答
【13262】Re:検索マクロ Hirofumi 04/4/29(木) 14:15 回答

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