HOME > Q&A > Excel （VBA）

Excel （VBA）
Excel VBAに関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Microsoft 365)
サブフォルダーまで検索をしたい
投稿日時: 24/07/12 16:06:41
投稿者: takatada72

お世話になります。
下記のコードは、UserForm5に版下確認, 仕様確認PDF, 仕様仮確認PDF, 仕様確認GP, 仕様仮確認GPの
TextBoxがあり、それぞれのフォルダーにファイルが存在していたら、TextBoxにファイル名を記載する
ようにしたいExcel vba コードになります。●仕様書仮にPDFがあるかを確認の所で、ファイルをサブフォルダーまで確認されていないことがわかり、AIに色々と聞いているのですが、私の認識が悪いため、良い回答が
もらえない状態です。最終手段として、こちらに質問をさせて頂ければ幸いです。
 
お忙しいとは思いますが宜しくお願い致します。
 
UserForm5.Show vbModeless 'フォームの表示
 
    Dim 行番号 As Integer
    Dim 版下P, 仕様P, 仮仕様P, ss, GP As String
    Dim 版下確認, 仕様確認PDF, 仕様仮確認PDF, 仕様確認GP, 仕様仮確認GP As String
     
     
 
   版下P = "\\Files_OK\"
   仕様P = "\\siyou_OK\"
   仮仕様P = "\\siyou_kari\"
  
     行番号 = ActiveCell.row '選択行の取得
     ss = Cells(行番号, 1).Value 'プライズ番号取得:例　O123456、Z123456など
      GP = Right(Cells(行番号, 3).Value, 7): 'GP番号取得:例　GP1234567、GP2343456など
 
       
 
UserForm5.TextBox1.Text = ""
UserForm5.TextBox2.Text = ""
UserForm5.TextBox3.Text = ""
UserForm5.TextBox4.Text = ""
UserForm5.TextBox5.Text = ""
 
    '版下があるかを確認
    版下確認 = Dir(版下P & ss & "*.pdf") '版下ファイル確認
    If 版下確認 <> "" Then
    UserForm5.TextBox1.Text = 版下確認
    End If
 
 
    '仕様書FIXのPDFがあるかを確認
    仕様確認PDF = Dir(仕様P & ss & "*.pdf") '版下ファイル確認
    If 仕様確認PDF <> "" Then
    UserForm5.TextBox2.Text = 仕様確認PDF
    End If
 
    '●仕様書仮にPDFがあるかを確認
    仕様仮確認PDF = Dir(仮仕様P & ss & "*.pdf") '版下ファイル確認
    If 仕様仮確認PDF <> "" Then
    UserForm5.TextBox3.Text = 仕様仮確認PDF
    End If
 
    '仕様書FIXのGPがあるかを確認
    仕様確認GP = Dir(仕様P & "*" & GP & "*.pdf") '版下ファイル確認
    If 仕様確認GP <> "" Then
    UserForm5.TextBox4.Text = 仕様確認GP
    End If
     
     
    '●仕様書仮にPDFがあるかを確認
    仕様仮確認GP = Dir(仮仕様P & "*" & GP & "*.pdf") '版下ファイル確認
    If 仕様仮確認GP <> "" Then
    UserForm5.TextBox5.Text = 仕様仮確認GP
    End If
回答
投稿日時: 24/07/15 22:41:10
投稿者: 半平太

こんな感じなのかなぁ・・
(環境を作るのが面倒なので、検証不十分ですけども)
 

Sub test()
    Dim 行番号 As Long
    Dim 版下P, 仕様P, 仮仕様P, ss, GP As String
    Dim 版下確認, 仕様確認PDF, 仕様仮確認PDF, 仕様確認GP, 仕様仮確認GP As String
    
    UserForm5.Show vbModeless 'フォームの表示
    
    版下P = "\\Files_OK"
    仕様P = "\\siyou_OK"
    仮仕様P = "\\siyou_kari"
    
    行番号 = ActiveCell.Row '選択行の取得
    ss = Cells(行番号, 1).Value 'プライズ番号取得:例　O123456、Z123456など
    GP = Right(Cells(行番号, 3).Value, 7): 'GP番号取得:例　GP1234567、GP2343456など

    UserForm5.TextBox1.Text = getPdfName(版下P, "\" & "*.pdf", False)
    UserForm5.TextBox2.Text = getPdfName(仕様P, "\" & ss & "*.pdf", False)
    UserForm5.TextBox3.Text = getPdfName(仮仕様P, "\" & ss & "*.pdf", True)
    UserForm5.TextBox4.Text = getPdfName(仕様P, "\" & GP & "*.pdf", False)
    UserForm5.TextBox5.Text = getPdfName(仮仕様P, "\" & GP & "*.pdf", True)    
End Sub

Private Function getPdfName(Path As Variant, pdfName As String, checkSubFolder As Boolean) As String
    Dim buf As String, subFld As Object, aa As Object
    
    buf = Dir(Path & pdfName)
    
    If buf <> "" Then
        getPdfName = buf
    ElseIf checkSubFolder Then
        With CreateObject("Scripting.FileSystemObject")
            For Each subFld In .GetFolder(Path).SubFolders
                getPdfName = getPdfName(subFld.Path, pdfName, checkSubFolder)
                Exit Function
            Next subFld
        End With
    End If
End Function
投稿日時: 24/07/16 13:37:39
投稿者: takatada72

半平太さん
 
早速、ありがとうございました。
PCが会社にしかないため、返信が遅くなりすみませんでした。
※お休み中の返信を頂きましてありがとうございました。m(_ _)m
 
何度か動作させた結果、AIに確認したところ、下記のように修正させて頂きました。
無事、サブフォルダーまでの検索ができましたのでありがとうございました。
 
 
   Dim buf As String, subFld As Object, aa As Object
     
    buf = Dir(Path & pdfName)
     
    If buf <> "" Then
        getPdfName = buf
    ElseIf checkSubFolder Then
        With CreateObject("Scripting.FileSystemObject")
            For Each subFld In .GetFolder(Path).subFolders
                ' サブフォルダー内も再帰的に検索するように修正
                getPdfName = getPdfName(subFld.Path, pdfName, checkSubFolder)
                ' ファイルが見つかった場合、ループを終了
                If getPdfName <> "" Then Exit Function
            Next subFld
        End With
    End If
    End Function