Excel VBA質問箱 IV

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

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


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

【56663】ブック名を取り込めませんか? いま 08/6/28(土) 15:25 質問[未読]
【56665】Re:ブック名を取り込めませんか? ゆみこん 08/6/28(土) 16:19 発言[未読]
【56666】Re:ブック名を取り込めませんか? Hirofumi 08/6/28(土) 16:46 回答[未読]

【56663】ブック名を取り込めませんか?
質問  いま  - 08/6/28(土) 15:25 -

引用なし
パスワード
   初心者ですが、VBAを使ってEXCELで作成した過去の見積ファイルを検索できるソフトを作りたいと思っております。
見積のブックは現在4000個程あるのですが、顧客名等を入力すると、該当する見積一覧をリスト化するようなものを作りたいと思っています。
そこで、フォルダ内のファイル名を取込→ブックOPEN→文字検索→リストに貼り付け→ブックCLOSE を全ブック繰り返すプログラムにしようかと思ったのですが、最初のファイル名取り込みの時点で行き詰まっています。
取り込み方法があれば教えていただけないでしょうか?
また、上記のようなソフトを作成するのに、もっと良い方法があれば教えていただけないでしょうか?

【56665】Re:ブック名を取り込めませんか?
発言  ゆみこん  - 08/6/28(土) 16:19 -

引用なし
パスワード
   ▼いま さん:
>初心者ですが、VBAを使ってEXCELで作成した過去の見積ファイルを検索できるソフトを作りたいと思っております。
>見積のブックは現在4000個程あるのですが、顧客名等を入力すると、該当する見積一覧をリスト化するようなものを作りたいと思っています。
>そこで、フォルダ内のファイル名を取込→ブックOPEN→文字検索→リストに貼り付け→ブックCLOSE を全ブック繰り返すプログラムにしようかと思ったのですが、最初のファイル名取り込みの時点で行き詰まっています。
>取り込み方法があれば教えていただけないでしょうか?
>また、上記のようなソフトを作成するのに、もっと良い方法があれば教えていただけないでしょうか?

かなり高度で且つ時間もかかるような。。。気がします。
業務であれば会社と相談しては?

【56666】Re:ブック名を取り込めませんか?
回答  Hirofumi  - 08/6/28(土) 16:46 -

引用なし
パスワード
   指定したフォルダのBook名を取得するのはこんなでも
(今、私が使っているコードです)
Sampleを試してください

Option Explicit

Public Sub Sample()

  Dim i As Long
  Dim rngResult As Range
  Dim vntFileNames As Variant
  Dim strSearchPath As String
  Dim lngSubDir As Long
  Dim strProm As String

  '◆出力Listの先頭セル位置を基準とする(A列の列見出しのセル位置)
  Set rngResult = Worksheets(1).Cells(1, "A")

  'ファイルを探す探すフォルダを指定
  strSearchPath = ThisWorkbook.Path
  
  '探すSubフォルダの階層を指定
  '指定フォルダのみの場合=0
  'Subフォルダ全ての場合=-1
  'すぐ下のフォルダまで=1
  '下の下なら=2
  lngSubDir = -1
  
  'ファイル名を抽出
  'strBasePattan:探すファイル名を正規表現で指定
  'strExtePattan:探すファイル名の拡張子を正規表現で指定
  If Not GetFilesList(vntFileNames, strSearchPath, ".*", "xls|xlsm|xlsx", lngSubDir) Then
    strProm = "ファイルが有りません"
    GoTo Wayout
  End If
  
  '結果を出力
  With rngResult
    .Resize(, 2).Value = Array("Path", "BookName")
    For i = 0 To UBound(vntFileNames, 2)
      .Offset(i + 1, 0).Value = vntFileNames(0, i)
      .Offset(i + 1, 1).Value = vntFileNames(1, i)
    Next i
  End With
  
  strProm = "処理が完了しました"
   
Wayout:

  Set rngResult = Nothing
   
  MsgBox strProm, vbInformation
     
End Sub

Public Function GetFilesList(vntFileNames As Variant, _
              strFolderPath As String, _
              Optional strBasePattan As String = ".*", _
              Optional strExtePattan As String = ".*", _
              Optional lngSubDir As Long = -1) As Boolean
              
  Const clngLower As Long = 0
  
  Dim objFSO As Object
  Dim regName As Object
  Dim vntRead As Variant
  
'  'FSOのオブジェクトを取得
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  'フォルダの存在確認
  If Not objFSO.FolderExists(strFolderPath) Then
    GoTo Wayout
  End If
  
  Set regName = CreateObject("VBScript.RegExp")
  '大文字と小文字を区別しないように設定
  regName.IgnoreCase = True

  'ファイル名List配列の初期化
  ReDim vntRead(1, clngLower To 1)
  'ファイル名Listの作成
  GetFilePath vntRead, _
        objFSO.GetFolder(strFolderPath), _
        strBasePattan, strExtePattan, _
        regName, objFSO, lngSubDir
  
  'ファイル名List配列の先頭値が""で無いなら
  If vntRead(0, clngLower) <> "" Then
    vntFileNames = vntRead
    GetFilesList = True
  End If
  
Wayout:
  
  Set objFSO = Nothing
  Set regName = Nothing

End Function

Private Sub GetFilePath(vntFileNames As Variant, _
            objFolder As Object, _
            strBasePattan As String, _
            strExtePattan As String, _
            regName As Object, _
            objFSO As Object, _
            ByVal lngSubDir As Long)

  Dim lngLower As Long
  Dim i As Long
  Dim objFile As Object
  Dim objSubDir As Object
  Dim strDirPath As String
  Dim strName As String
  
  'List配列の最小添え字を取得
  lngLower = LBound(vntFileNames, 2)
  'List配列に値が有る場合
  If vntFileNames(0, lngLower) <> "" Then
    'カウンタをList配列の最大添え字に設定
    i = UBound(vntFileNames, 2)
  Else
    'カウンタをList配列の最小添え字以下に設定
    i = lngLower - 1
  End If
  
  '現在のFoderPathを取得
  strDirPath = objFolder.Path & "\"
  'ファイル名を列挙
  For Each objFile In objFolder.Files
    strName = objFile.Name
    With regName
      '拡張子を比較
      .Pattern = strExtePattan
      If .TEST(objFSO.GetExtensionName(strName)) Then
        'Base名を比較
        .Pattern = strBasePattan
        If .TEST(objFSO.GetBaseName(strName)) Then
          '先頭に"~$"が無いなら
          If Left(strName, 2) <> "~$" Then
            'カウンタをインクリメント
            i = i + 1
            'List配列を拡張
            ReDim Preserve vntFileNames(1, lngLower To i)
            'Path、ファイル名を代入
            vntFileNames(0, i) = strDirPath
            vntFileNames(1, i) = strName
          End If
        End If
      End If
    End With
  Next objFile

  Set objFile = Nothing
  
  '指定階層数になるまで再帰、lngSubDir < 0 の時は最終階層まで再帰
  If lngSubDir > 0 Or lngSubDir < 0 Then
    '階層指定を一つ下げる
    lngSubDir = lngSubDir - 1
    'SubFolderを探索
    For Each objSubDir In objFolder.SubFolders
      GetFilePath vntFileNames, objSubDir, _
            strBasePattan, strExtePattan, _
            regName, objFSO, lngSubDir
    Next objSubDir
  End If
  
  Set objSubDir = Nothing
  
End Sub

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