[[20221005114944]]　『DIr関数での部分一致』（Kozzy）　ページの最後に飛ぶ

『DIr関数での部分一致』（Kozzy）

質問させてください。

VBAのDir関数での部分一致でワイルドカードを使う時に
「*○○*」
はよく見るのですが、
「○○*●●.拡張子」
のように二つの文字列を部分一致させる方法はないのでしょうか？

「○○*●●.拡張子」でやってみたら空白が返ってきたもので・・・

よろしくお願いします。

＜使用 Excel：unknown、使用 OS：unknown ＞

意味が解らない
（unknown） 2022/10/05(水) 12:16

 実際にどうプログラムを組んでなんというファイルが該当するはずだったのかを示してみてくれないか？
（ねむねむ） 2022/10/05(水) 12:27

編集が、かぶりましたがそのまま。

もう少し詳細な情報は提示できませんか？
例えばDドライブ直下に↓のようにあった場合

 ああ01ああ.xlsx
 ああ01いい.xlsx
 ああ02ああ.xlsx
 ああ01ああ.txt

    Sub 実験()
        Dim ファイル名 As String

        ファイル名 = Dir("D:\ああ*ああ.xlsx")
        Do Until ファイル名 = ""
            Debug.Print ファイル名
            ファイル名 = Dir()
        Loop
    End Sub

↑を実行すると、イミディエイトに↓のように取り出されると思います

 ああ01ああ.xlsx
 ああ02ああ.xlsx

やりたいことはそういうことですよね？
条件が合っていてヒットしなかったということは、

 フォルダがまちがっていた
 フルパスが長くてDir関数で扱える文字数を越えた

などが怪しい気がします。

（もこな２） 2022/10/05(水) 12:33

すみません。
ショートカットだから探せなかったみたいです。
お騒がせしました。
（Kozzy） 2022/10/05(水) 13:01

 lnkをDir関数でループし、ショートカットのリンク先
 パスの拡張子が指定の拡張子だったら判定に
 回す、という方法も。
（MK） 2022/10/05(水) 18:45

＞ショートカットのリンク先パスの拡張子
スマホからなのでちょっと試せませんが、Dir関数で【リンク先パス】って取得できましたっけ？
lnkのファイル名を言っているのだとしたら、ショートカットのファイル名自体は好きに変えられますから、おもわく通りのファイル名とは限らないようにおもいます。

（もこな２） 2022/10/05(水) 18:59

試してみました。

ショートカットのパスで元ファイルを開くことが出来ますね。
ショートカット自体のファイル名を変更しても同様に。
（Kozzy） 2022/10/06(木) 09:01

↓で紹介されているような方法でlnkのリンク先のパス
を取得できます。
http://officetanaka.net/other/extra/tips12.htm
（MK） 2022/10/06(木) 18:18

＞↓で紹介されているような方法でlnkのリンク先のパス
丁度おなじサイトを見ていていました。
やっぱり【DIR関数】で（直接）リンク先は見れないですよね。
なので↓みたいな説明になるんじゃないかというお話でした。

 lnkをDir関数でループし、【WSH等で】ショートカットのリンク先【を取得して】
 パスの拡張子が指定の拡張子だったら判定に回す、

もともと、そういう趣旨だったということなら余計なツッコミごめんなさい。

（もこな２） 2022/10/06(木) 18:39

 >lnkをDir関数でループし、【WSH等で】ショートカットのリンク先【を取得して】
 >パスの拡張子が指定の拡張子だったら判定に回す、

 言葉足らずでした。その通りです。

 私はDir関数は使いますが、FileSystemObjectを使うことのほうが多いです。
 指定のフォルダ以下のサブフォルダ内で指定の拡張子でファイル名に指定の
 キーワードが含まれるファイル一覧を取得するものです。
 記述に無駄が多いとは思いますが参考まで。

Dim FSO As Object
Dim cnt As Integer
Dim ws As Worksheet
Dim kakudic As Object

Sub test()

 Dim fol As String
 Dim kw As String
 Dim andor As Boolean
  andor = True 'True=AND/False=OR
  kw = "1　9" 'キーワード/複数のキーワードで検索する場合はキーワードをスペースで挟む

  Set kakudic = CreateObject("Scripting.Dictionary") '検索対象のファイルの拡張子
  kakudic.Add "xlsx", "xlsx"
  kakudic.Add "xlsm", "xlsm"
  kakudic.Add "xls", "xls"

  Set FSO = CreateObject("Scripting.FileSystemObject")

  fol = CreateObject("WScript.Shell").SpecialFolders("Desktop") '検索するフォルダを指定

  Set ws = ThisWorkbook.Worksheets(1) '検索結果をワークシートに転記する
  ws.Cells.Delete
  cnt = 0
  Call fget(FSO.getfolder(fol), kw, andor)
  Set ws = Nothing
  Set FSO = Nothing
  kakudic.RemoveAll
  Set kakudic = Nothing
End Sub

Function fget(ByVal objfol As Object, mykw As String, andor As Boolean)

 Dim objWShell As Object
 Dim objSCut As Object
 Dim objfile As Object
 Dim objsubfol As Object
 Dim mypath As String
 Dim bs As String
 Dim kaku As String
  Set objWShell = CreateObject("WScript.Shell")
  For Each objfile In objfol.Files
   mypath = objfile.Path
   If FSO.getextensionname(mypath) = "lnk" Then
      Set objSCut = objWShell.CreateShortcut(mypath)
      mypath = objSCut.TargetPath
      Set objSCut = Nothing
   End If
   If FSO.fileexists(mypath) Then
      kaku = FSO.getextensionname(mypath)
      bs = FSO.getbasename(mypath)
      If kakudic.exists(kaku) And hantei(mykw, bs, andor) = True Then
         cnt = cnt + 1
         ws.Cells(cnt, 2).Value = "File"
         ws.Cells(cnt, 3).Value = FSO.getfile(mypath).Name
         ws.Cells(cnt, 1).Value = mypath
      End If
   ElseIf FSO.folderexists(mypath) Then
      Call fget(FSO.getfolder(mypath), mykw, andor)
   End If
  Next objfile
  For Each objsubfol In objfol.subfolders
    Call fget(objsubfol, mykw, andor)
  Next objsubfol
  Set objWShell = Nothing
End Function

'Functionの引数でAND/OR分岐
’検索元文字列とキーワードを全て全角化・大文字化して判定
Function hantei(ByVal keywd As String, fmei As String, andor As Boolean) As Boolean

 Dim sp As Variant
 Dim i As Integer
 Dim bl As Boolean
  keywd = StrConv(StrConv(keywd, 4), 1)
  sp = Split(keywd, "　")
   If andor = True Then 'AND検索
      hantei = True
      For i = 0 To UBound(sp)
       If StrConv(StrConv(fmei, 4), 1) Like "*" & sp(i) & "*" Then
       Else
          hantei = False
          Exit For
       End If
      Next i
   Else 'OR検索
      hantei = False
      For i = 0 To UBound(sp)
       If StrConv(StrConv(fmei, 4), 1) Like "*" & sp(i) & "*" Then
          hantei = True
          Exit For
       End If
      Next i
   End If
End Function

（MK） 2022/10/06(木) 20:07

 ちなみに、私が使っているエクセルのバージョンは2007です。
 ですので、最新のエクセルのVBAに備わっている機能は使えません・・・。
（MK） 2022/10/06(木) 20:10

 ↑のコードはフォルダのショートカットも含めて再起処理
 を行っているので、同じサブフォルダ、同じファイルを検索結果
 としてリストアップする可能性があります。
 一回見たサブフォルダや、リストアップ済みのファイルをDictionary
 オブジェクトに格納するなりしてダブりを回避する必要があります。
（MK） 2022/10/06(木) 20:39

 一旦検索したフォルダや検索済みファイルを除外する
 バージョンです。

Dim FSO As Object
Dim cnt As Integer
Dim ws As Worksheet
Dim kakudic As Object
Dim pathdic As Object

Sub test()

 Dim fol As String
 Dim kw As String
 Dim andor As Boolean
  Set pathdic = CreateObject("Scripting.Dictionary") '検索済のフォルダやファイルを格納
  andor = True 'True=AND/False=OR
  kw = "ああ　いい　うう" 'キーワード/複数のキーワードで検索する場合はキーワードをスペースで挟む
  Set kakudic = CreateObject("Scripting.Dictionary") '検索対象のファイルの拡張子
  kakudic.Add "xlsx", "xlsx"
  kakudic.Add "docx", "docx"
  kakudic.Add "pdf", "pdf"
  Set FSO = CreateObject("Scripting.FileSystemObject")
  fol = CreateObject("WScript.Shell").SpecialFolders("Desktop") '検索するフォルダを指定
  pathdic.Add fol, fol
  Set ws = ThisWorkbook.Worksheets(1) '検索結果をワークシートに転記する
  ws.Cells.Delete
  cnt = 0
  Call fget(FSO.getfolder(fol), kw, andor)
  Set ws = Nothing
  Set FSO = Nothing
  kakudic.RemoveAll
  Set kakudic = Nothing
  pathdic.RemoveAll
  Set pathdic = Nothing
End Sub

Function fget(ByVal objfol As Object, mykw As String, andor As Boolean)

 Dim objWShell As Object
 Dim objSCut As Object
 Dim objfile As Object
 Dim objsubfol As Object
 Dim mypath As String
 Dim bs As String
 Dim kaku As String
  Set objWShell = CreateObject("WScript.Shell")
  For Each objfile In objfol.Files
   mypath = objfile.Path
   If FSO.getextensionname(mypath) = "lnk" Then
      Set objSCut = objWShell.CreateShortcut(mypath)
      mypath = objSCut.TargetPath
      Set objSCut = Nothing
   End If
   If FSO.fileexists(mypath) Then
      If pathdic.exists(mypath) Then
      Else
       pathdic.Add mypath, mypath
         kaku = FSO.getextensionname(mypath)
         bs = FSO.getbasename(mypath)
         If kakudic.exists(kaku) And hantei(mykw, bs, andor) = True Then
            cnt = cnt + 1
            ws.Cells(cnt, 2).Value = "File"
            ws.Cells(cnt, 3).Value = FSO.getfile(mypath).Name
            ws.Cells(cnt, 1).Value = mypath
         End If
      End If
   ElseIf FSO.folderexists(mypath) Then
      If pathdic.exists(mypath) Then
      Else
        pathdic.Add mypath, mypath
         Call fget(FSO.getfolder(mypath), mykw, andor)
      End If
   End If
  Next objfile
  For Each objsubfol In objfol.subfolders
   If pathdic.exists(mypath) Then
   Else
     pathdic.Add mypath, mypath
     Call fget(objsubfol, mykw, andor)
   End If
  Next objsubfol
  Set objWShell = Nothing
End Function

'Functionの引数でAND/OR分岐
'検索元文字列とキーワードを全て全角化・大文字化して判定
Function hantei(ByVal keywd As String, fmei As String, andor As Boolean) As Boolean

 Dim sp As Variant
 Dim i As Integer
 Dim bl As Boolean
  keywd = StrConv(StrConv(keywd, 4), 1)
  sp = Split(keywd, "　")
   If andor = True Then 'AND検索
      hantei = True
      For i = 0 To UBound(sp)
       If StrConv(StrConv(fmei, 4), 1) Like "*" & sp(i) & "*" Then
       Else
          hantei = False
          Exit For
       End If
      Next i
   Else 'OR検索
      hantei = False
      For i = 0 To UBound(sp)
       If StrConv(StrConv(fmei, 4), 1) Like "*" & sp(i) & "*" Then
          hantei = True
          Exit For
       End If
      Next i
   End If
End Function
（MK） 2022/10/07(金) 10:11:32

 Function fget(ByVal objfol As Object, mykw As String, andor As Boolean)
 ↑のコードに不備がありました。

 For Each objsubfol In objfol.subfolders

 の直下に

 mypath = objsubfol.Path

 を付加してください。
（MK） 2022/10/08(土) 07:12:47

コメント返信：

[ 一覧(最新更新順) ]

[[20221005114944]] 『DIr関数での部分一致』（Kozzy） ページの最後に飛ぶ

[[20221005114944]]　『DIr関数での部分一致』（Kozzy）　ページの最後に飛ぶ