Excel VBA質問箱 IV

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

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


7989 / 76732 ←次へ | 前へ→

【74324】Re:Next で行まで初期化してしまうかどうか
発言  kanabun  - 13/5/22(水) 23:46 -

引用なし
パスワード
   ▼にしもり さん:

その他の方法として 以下の2方法もあると思います。

(1)貼付行も 呼び出し時にパラメータ(引数)として渡す方法

Sub Sample()
  Call FileSearch("C:\_cosmos\Tr")
End Sub

'「貼付け行」も呼び出し側で指定する
Sub FileSearch(Path As String, 貼付行 As Long)
  Dim Folder As Object
  Dim File As Object

  With CreateObject("Scripting.FileSystemObject")
    For Each Folder In .GetFolder(Path).SubFolders
      
      Call FileSearch(Folder.Path, 貼付行)

      For Each File In .GetFolder(Path).Files
        貼付行 = 貼付行 + 1
        Cells(貼付行, 1).Value = File.Path
      Next File

    Next Folder
  End With

End Sub


(2) 上の方法は FSOを使っていることと、1ファイルづつ都度セルに
  書き込んでいるので、ファイル数が多くなると遅くなります。
  Dirコマンドで検索し、検索結果を配列に格納して シートに
  一括して書き込むようにすれば、格段にスピードアップします。

Sub Sample2()
 Dim n As Long
 Dim FoundFiles() As String

  n = SearchFiles("C:\_cosmos\Tr", "*.*", FoundFiles())
  If n > 0 Then
    Range("B1").Resize(n).Value = _
         Application.Transpose(FoundFiles)
  End If
End Sub

'//サブフォルダを含むファイルの一覧
Function SearchFiles(LookIn As String, Filename As String, _
          FoundFiles() As String) As Long
  Dim i As Long
  Dim Ext As Variant
  Dim tmpPath As String
  Dim sCmd As String
  Dim ko As Long
  
  If Right$(LookIn, 1) <> "\" Then LookIn = LookIn & "\"
  If InStr(Filename, ";") > 0 Then
    Ext = Split(Filename, ";")
    For i = 0 To UBound(Ext)
      Ext(i) = LookIn & Ext(i)
    Next
    Filename = Join(Ext, """ """)
  Else
    Filename = LookIn & Filename
  End If
  tmpPath = LookIn & "Dir.tmp"   'Dirの結果を一時ファイルに出力
  sCmd = "DIR """ & Filename & """ /b/s/o:N > """ & tmpPath & """"
           '' /b ファイル名のみ
           '' /s サブディレクトリも検索
           '' /o:N 名前順でソート
  With CreateObject("WScript.Shell")
    ko = .Run("CMD /C " & sCmd, 7, True) 'Dirコマンド実行
  End With
  If ko Then
    MsgBox "ファイルの検索に失敗しました", , LookIn
    Exit Function
  End If
  If FileLen(tmpPath) < 2 Then Exit Function
  
  Dim io As Integer
  Dim buf() As Byte
  io = FreeFile()
  Open tmpPath For Binary As io
   ReDim buf(1 To LOF(io))
   Get #io, , buf
  Close io
  Kill tmpPath
  FoundFiles() = Split(StrConv(buf, vbUnicode), vbCrLf)
  ko = UBound(FoundFiles)
  ReDim Preserve FoundFiles(ko - 1)
  SearchFiles = ko
  
End Function

1 hits

【74322】Next で行まで初期化してしまうかどうか にしもり 13/5/22(水) 19:16 質問
【74323】Re:Next で行まで初期化してしまうかどうか kanabun 13/5/22(水) 19:31 発言
【74324】Re:Next で行まで初期化してしまうかどうか kanabun 13/5/22(水) 23:46 発言
【74325】Re:Next で行まで初期化してしまうかどうか kanabun 13/5/22(水) 23:48 発言
【74336】Re:Next で行まで初期化してしまうかどうか kanabun 13/5/23(木) 20:08 発言
【74338】Re:Next で行まで初期化してしまうかどうか にしもり 13/5/24(金) 6:04 お礼
【74339】Re:Next で行まで初期化してしまうかどうか kanabun 13/5/24(金) 9:18 発言
【74326】Re:Next で行まで初期化してしまうかどうか kanabun 13/5/23(木) 0:41 発言
【74327】Re:Next で行まで初期化してしまうかどうか にしもり 13/5/23(木) 5:19 発言

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