Excel VBA質問箱 IV

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

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


19144 / 76734 ←次へ | 前へ→

【63026】Re:ファイルの抽出
発言  kanabun  - 09/10/1(木) 20:24 -

引用なし
パスワード
   ▼さくら さん:

>確認・検証後、また結果等書き込みに参ります。

ちょっと時間があったもので、
上のDir関数をつかったサブフォルダを含むファイル(*.xls)の検索スピードと
FileSystemObjectによる検索と
FindFile APIによる検索スピードを比較してみました。
以下が、あるフォルダを3つの方法で検索したときの処理時間です。

'方法 Hit数   所要時間(ミリ秒)
Dir ( 1113 )  1497 
Fso ( 1122 )  10358
API ( 1122 )   234

ということで、Fsoは論外、Dirはそこそこの時間ですが、ヒットした
ファイルの数が他の方法に比較して少ない(検索漏れがある?)、
やはり APIを使ったほうが 桁違いに時間が短縮されるし、
パスの長さの制限や、Unicodeで検索できるなど安心ですので、
以下に、FindFileW APIを使ったコードを紹介しておきますね

Dirの方法に比べ、コードは
先頭の宣言部にいろいろ宣言があり、とっつきにくいですが、
Sub FindFile() の中でやっていることは
前の Dirによる FileSearch() でやってることと「瓜二つ」
なので、読み比べてみてください。

なお、説明し忘れましたが、
検索フォルダの設定は どちらのマクロも 以下のところです。
> Dim LookIn As String: LookIn = "D:\(Data)\"
ここをそちらの環境に替えてお試しください。

'----------------------------------------------------------
Option Explicit

Private Const MAX_PATH = 260
Private Const INVALID_HANDLE = (-1)

' WIN32_FIND_DATA構造体
Private Type WIN32_FIND_DATA
  dwFileAttributes  As Long
  ftCreationTime   As Currency
  ftLastAccessTime  As Currency
  ftLastWriteTime   As Currency
  nFileSizeHigh    As Long
  nFileSizeLow    As Long
  dwReserved0     As Long
  dwReserved1     As Long
  cFileName(1 To MAX_PATH * 2) As Byte
  cAlternate(1 To 14 * 2) As Byte
End Type

Private Declare Function FindFirstFile _
       Lib "kernel32" Alias "FindFirstFileW" _
        (ByVal lpFileName As Long, _
        lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile _
       Lib "kernel32" Alias "FindNextFileW" _
         (ByVal hFindFile As Long, _
         lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose _
       Lib "kernel32" _
         (ByVal hFindFile As Long) As Long
'----------------------------------------------------------
'処理時間計測用
Private Declare Function timeGetTime Lib "winmm.dll" () As Long

'for さくら
Sub さくら3_API()
  Dim LookIn As String: LookIn = "D:\(Data)\"
  Dim Filename As String: Filename = "*.xls"
  Dim FoundFiles() As String
  Dim nCount As Long
  Dim mCount As Long
  Dim t&
  
  t& = timeGetTime()
  'LookIn   : 検索Rootフォルダ
  'Filename  : 検索ファイル名
  'FoundFiles(): マッチしたファイル名の配列()
  'nCount   : ファイルの数
  'mCount   : RootおよびRoot直下のフォルダ数
  FindFile LookIn, LCase$(Filename), FoundFiles(), nCount, mCount, 0
  
  Debug.Print "'API("; nCount - mCount; ")", timeGetTime() - t
  If (nCount - mCount) > 0 Then
    Dim r As Range, c As Range
    With Worksheets
      With .Add(After:=.Item(.Count))
        Set r = .[A1].Resize(nCount, 2)
        r.Value = Trans(FoundFiles())
        Application.ScreenUpdating = 0
        On Error Resume Next
         For Each c In r.Columns(2). _
           Cells.SpecialCells(xlConstants).Areas
           .Sort Key1:=c.Item(1), Header:=xlNo
         Next
        On Error GoTo 0
        Application.ScreenUpdating = 1
      End With
    End With
    MsgBox nCount - mCount & "個のファイルがマッチしました"
  End If
End Sub

Private Sub FindFile(strDir As String, strFind As String, _
        FoundFiles() As String, nCount As Long, _
        mCount As Long, ByVal Level As Long)
 Dim p As String
 Dim fDATA As WIN32_FIND_DATA
 Dim f As String
 Dim hFile As Long
 Dim strName As String
 Dim i As Long
 Dim SubDir() As String, nSub As Long

 If Right$(strDir, 1) <> "\" Then strDir = strDir & "\"
 
 p = strDir & "*.*"  'すべてのファイルを検索
 hFile = FindFirstFile(StrPtr(p), fDATA)
 If hFile = INVALID_HANDLE Then Exit Sub
 
 If Level <= 1 Then
   nCount = nCount + 1
   mCount = mCount + 1
   ReDim Preserve FoundFiles(1, 1 To nCount)
   FoundFiles(0, nCount) = strDir '現在フォルダ名出力
 End If
 Do
   f = fDATA.cFileName
   f = Left$(f, InStr(f, vbNullChar) - 1)
   If fDATA.dwFileAttributes And vbDirectory Then
     If Left$(f, 1) <> "." Then
      ' サブフォルダならば 配列SubDir() に一時記憶
       nSub = nSub + 1
       ReDim Preserve SubDir(1 To nSub)
       SubDir(nSub) = strDir & f
     End If
     
   Else
     strName = LCase$(f)
     If strName Like strFind Then
      ' 検索ファイル名にマッチしたファイルの出力
       nCount = nCount + 1
       ReDim Preserve FoundFiles(1, 1 To nCount)
       FoundFiles(1, nCount) = strName
     End If
   End If
 
 Loop While FindNextFile(hFile, fDATA)
 FindClose hFile
 
 '------------
 'サブフォルダ内の検索
 If nSub Then
   For i = 1 To nSub
     FindFile SubDir(i), strFind, FoundFiles(), nCount, mCount, Level
   Next
 End If
End Sub

Private Function Trans(ff() As String) As String()
  Dim sv() As String
  Dim i As Long, n As Long
  n = UBound(ff, 2)
  ReDim sv(1 To n, 1)
  For i = 1 To n
    sv(i, 0) = ff(0, i)
    sv(i, 1) = ff(1, i)
  Next
  Trans = sv()
End Function
4 hits

【62954】ファイルの抽出 さくら 09/9/25(金) 16:57 質問
【62955】Re:ファイルの抽出 neptune 09/9/25(金) 17:51 発言
【62970】Re:ファイルの抽出 さくら 09/9/28(月) 13:32 発言
【62972】Re:ファイルの抽出 kanabun 09/9/28(月) 14:47 発言
【62979】Re:ファイルの抽出 kanabun 09/9/28(月) 23:42 発言
【63023】Re:ファイルの抽出 さくら 09/10/1(木) 15:23 発言
【63026】Re:ファイルの抽出 kanabun 09/10/1(木) 20:24 発言
【63027】Re:ファイルの抽出 kanabun 09/10/1(木) 20:27 発言

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