Excel VBA質問箱 IV

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

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


1323 / 13645 ツリー ←次へ | 前へ→

【75011】ファイル検索とリンク設定 Kohaku 13/11/14(木) 13:28 質問[未読]
【75013】Re:ファイル検索とリンク設定 kanabun 13/11/14(木) 17:48 発言[未読]
【75024】Re:ファイル検索とリンク設定 Kohaku 13/11/15(金) 18:20 お礼[未読]
【75025】Re:ファイル検索とリンク設定 kanabun 13/11/15(金) 18:54 発言[未読]
【75043】Re:ファイル検索とリンク設定 Kohaku 13/11/18(月) 14:11 お礼[未読]
【75082】Re:ファイル検索とリンク設定 kohaku 13/12/9(月) 19:11 質問[未読]
【75088】Re:ファイル検索とリンク設定 kanabun 13/12/10(火) 13:12 発言[未読]
【75091】Re:ファイル検索とリンク設定 kohaku 13/12/10(火) 16:32 お礼[未読]

【75011】ファイル検索とリンク設定
質問  Kohaku  - 13/11/14(木) 13:28 -

引用なし
パスワード
   目的:シート内のセルに該当ファイルのフルパス名のリンクを張りたい

シート例)
SEQ. 番号 名前
1  100 xxxxx 
2  200 xxxxx
3  300 xxxxx

例えば、 1行目の 番号 100に '.pdf' をつけて 100.pdf として
ネットワーク越しのフォルダ内を検索し、存在した時にそのフルパス名の
リンクを名前欄の右セルにセットしたい

検索対象のフォルダ階層は以下のとおりです。
・最上位親フォルダ
  ・子フォルダA
  ・子フォルダB
    ・孫フォルダ x
目的のPDFファイルはどのフォルダに格納されているかは、
わかりません。

何卒、ご教授のほど、よろしくお願い致します。

【75013】Re:ファイル検索とリンク設定
発言  kanabun  - 13/11/14(木) 17:48 -

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

>例えば、 1行目の 番号 100に '.pdf' をつけて 100.pdf として
>ネットワーク越しのフォルダ内を検索し、存在した時にそのフルパス名の
>リンクを名前欄の右セルにセットしたい

一例ですが、
サブフォルダを含むファイルの検索は Dirコマンド というのを使うと
比較的簡単に、けっこう速く、取得できると思います。
今回は すべて*.pdf という拡張子なので、Dirコマンドですべての*.pdf
ファイルを取得します。

取得した{ファイル名; パス名} の組は Dictionary に登録しておくと、
シートのファイル名が辞書のキーにあれば、対応するパス名が辞書から
取得できます。

'事前に Microsoft Scripting Runtimeへの参照設定が必要です
Sub Try1()
  Dim dic As Dictionary
  'Const NETPath = "\\EPSON1120\Data (D)\(Data)\*.pdf"
  Const NETPath = "\\B450\(Pub)\*.pdf" '◆適宜変更
  
  Dim tmpFile As String
  Dim strCmd As String
  Dim buf() As Byte
  Dim fList() As String, f As String, s As String
  Dim i As Long, j As Long, n As Long

  'Dirコマンドの結果を出力する一時ファイル
  tmpFile = Environ$("TEMP") & "\Dir.tmp"
  
  'Dirコマンド用の文字列を編集
  strCmd = "Dir """ & NETPath & """ /b/s > """ & tmpFile & """"
  
  'WSHでDirコマンドを実行
  With CreateObject("Wscript.Shell")
     .Run "cmd /c" & strCmd, 7, True
  End With
  
  '該当ファイルの存在チェック
  If FileLen(tmpFile) < 1 Then
    MsgBox "該当するファイルがありません"
    Exit Sub
  End If
  
  'Dirコマンドの結果を出力した一時ファイルを読み込み
  Open tmpFile For Binary As #1
    ReDim buf(1 To LOF(1))
    Get #1, , buf
  Close #1
  Kill tmpFile '読んだら一時アイルは削除
  
  '取得したパス名をリスト用配列に入れます
  fList() = Split(StrConv(buf, vbUnicode), vbCrLf)
  n = UBound(fList)
  '{ファイル名とパス名}を辞書に登録します
  Set dic = New Dictionary
  dic.CompareMode = TextCompare
  For i = 0 To n - 1
    s = fList(i)     'パス名
    j = InStrRev(s, "\")
    f = Mid$(s, j + 1)  '正味ファイル名
    dic(f) = s
    'Debug.Print f, s
  Next
  
  'シートのA列のファイル名が辞書にあればそのパス名を取得します
  Dim r As Range
  Dim v As Variant
  Set r = Range("A2", Cells(Rows.Count, 1).End(xlUp))
  v = r.Value
  For i = 1 To UBound(v)
    If dic.Exists(v(i, 1)) Then
      v(i, 1) = dic(v(i, 1)) 'そのファイルのあるパス名
    Else
      v(i, 1) = ""
    End If
  Next
  'シートのB列に検索結果を貼り付ける
  r.Offset(, 1).Value = v
End Sub

【75024】Re:ファイル検索とリンク設定
お礼  Kohaku  - 13/11/15(金) 18:20 -

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

kanabun様、早速ご回答頂きまして誠にありがとうございます。
教えて頂きました内容を元に自分なりにやってみましたが、
>If dic.Exists(v(i, 1)) の部分でつまづいております。

excelのセル中にはpdfの拡張子がついていませんが、
上記の記述で存在チェックは可能なのでしょうか?
再度ご教授願えないでしょうか。

よろしくお願い致します。


>▼Kohaku さん:
>
>>例えば、 1行目の 番号 100に '.pdf' をつけて 100.pdf として
>>ネットワーク越しのフォルダ内を検索し、存在した時にそのフルパス名の
>>リンクを名前欄の右セルにセットしたい
>
>一例ですが、
>サブフォルダを含むファイルの検索は Dirコマンド というのを使うと
>比較的簡単に、けっこう速く、取得できると思います。
>今回は すべて*.pdf という拡張子なので、Dirコマンドですべての*.pdf
>ファイルを取得します。
>
>取得した{ファイル名; パス名} の組は Dictionary に登録しておくと、
>シートのファイル名が辞書のキーにあれば、対応するパス名が辞書から
>取得できます。
>
>'事前に Microsoft Scripting Runtimeへの参照設定が必要です
>Sub Try1()
>  Dim dic As Dictionary
>  'Const NETPath = "\\EPSON1120\Data (D)\(Data)\*.pdf"
>  Const NETPath = "\\B450\(Pub)\*.pdf" '◆適宜変更
>  
>  Dim tmpFile As String
>  Dim strCmd As String
>  Dim buf() As Byte
>  Dim fList() As String, f As String, s As String
>  Dim i As Long, j As Long, n As Long
>
>  'Dirコマンドの結果を出力する一時ファイル
>  tmpFile = Environ$("TEMP") & "\Dir.tmp"
>  
>  'Dirコマンド用の文字列を編集
>  strCmd = "Dir """ & NETPath & """ /b/s > """ & tmpFile & """"
>  
>  'WSHでDirコマンドを実行
>  With CreateObject("Wscript.Shell")
>     .Run "cmd /c" & strCmd, 7, True
>  End With
>  
>  '該当ファイルの存在チェック
>  If FileLen(tmpFile) < 1 Then
>    MsgBox "該当するファイルがありません"
>    Exit Sub
>  End If
>  
>  'Dirコマンドの結果を出力した一時ファイルを読み込み
>  Open tmpFile For Binary As #1
>    ReDim buf(1 To LOF(1))
>    Get #1, , buf
>  Close #1
>  Kill tmpFile '読んだら一時アイルは削除
>  
>  '取得したパス名をリスト用配列に入れます
>  fList() = Split(StrConv(buf, vbUnicode), vbCrLf)
>  n = UBound(fList)
>  '{ファイル名とパス名}を辞書に登録します
>  Set dic = New Dictionary
>  dic.CompareMode = TextCompare
>  For i = 0 To n - 1
>    s = fList(i)     'パス名
>    j = InStrRev(s, "\")
>    f = Mid$(s, j + 1)  '正味ファイル名
>    dic(f) = s
>    'Debug.Print f, s
>  Next
>  
>  'シートのA列のファイル名が辞書にあればそのパス名を取得します
>  Dim r As Range
>  Dim v As Variant
>  Set r = Range("A2", Cells(Rows.Count, 1).End(xlUp))
>  v = r.Value
>  For i = 1 To UBound(v)
>    If dic.Exists(v(i, 1)) Then
>      v(i, 1) = dic(v(i, 1)) 'そのファイルのあるパス名
>    Else
>      v(i, 1) = ""
>    End If
>  Next
>  'シートのB列に検索結果を貼り付ける
>  r.Offset(, 1).Value = v
>End Sub

【75025】Re:ファイル検索とリンク設定
発言  kanabun  - 13/11/15(金) 18:54 -

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

>>If dic.Exists(v(i, 1)) の部分でつまづいております。
>
>excelのセル中にはpdfの拡張子がついていませんが、
>上記の記述で存在チェックは可能なのでしょうか?

セルには拡張子".pdf"がついていないのでしたら、拡張子を追加して
dic.Exists(ファイル名) としてください。(下記参照)


>>  Set r = Range("A2", Cells(Rows.Count, 1).End(xlUp))
>>  v = r.Value
>>  For i = 1 To UBound(v)
     s = v(i, 1) & ".pdf"
     If dic.Exists(s) Then
       v(i, 1) = dic(s) 'そのファイルのあるパス名
>>    Else
>>      v(i, 1) = ""
>>    End If
>>  Next
>>  'シートのB列に検索結果を貼り付ける
>>  r.Offset(, 1).Value = v
>>End Sub

【75043】Re:ファイル検索とリンク設定
お礼  Kohaku  - 13/11/18(月) 14:11 -

引用なし
パスワード
   kanabun様

やりたい事が出来ました。
教えて頂き、本当にありがとうございました。

【75082】Re:ファイル検索とリンク設定
質問  kohaku  - 13/12/9(月) 19:11 -

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

先日はお教え頂き、ありがとうございました。
仕様のバージョンアップが必要となり、悩んでおります。
是非追加でご教授頂けないかと、投稿致しました。
何卒、よろしくお願い申し上げます。

追加仕様:
セルの内容: 12345*  -->  実際のファイル名: 123451.pdf
上記のようなPDFファイルは1個しか存在しないことは分かっています。

現状は下記のとおり記述しておりますので、pdfファイルがありませんと
セルに入ってしまいます。
 
  If Range("C2") <> "" Then
    s = Range("C2") & ".pdf"
    If dic.Exists(s) Then
     Range("K2").Value = dic(s)
     With ActiveSheet
       .Hyperlinks.Add anchor:=Range("k2"), dress:=Range("k2").Value
     End With
    Else
     Range("K2").Value = "PDFファイルが存在しません。"
     With ActiveSheet
       .Hyperlinks.Delete
     End With
    End If
  Else
     Range("K2").Value = ""
  End

■配列の中身を曖昧検索するには、どのように記述すればよいのでしょうか?

【75088】Re:ファイル検索とリンク設定
発言  kanabun  - 13/12/10(火) 13:12 -

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

失礼しました。見過ごしていました m(_ _)m

>仕様のバージョンアップが必要となり、悩んでおります。
>
>追加仕様:
>セルの内容: 12345*  -->  実際のファイル名: 123451.pdf
>上記のようなPDFファイルは1個しか存在しないことは分かっています。

>■配列の中身を曖昧検索するには、どのように記述すればよいのでしょうか?

ワークシート関数のMATCHを使って、配列のワイルドカードを使った検索が
できますので、セルの値に * が含まれていたら、Match関数で実在する
123451.pdf
の位置を求め、フルパスを取得したらどうでしょうか?


Sub Try1() の以下の部分を修正してみましたから、
これを応用してそちらのコードを修正してみてください。

  'シートのA列のファイル名が辞書にあればそのパス名を取得します
  Dim fArray
  fArray = dic.Keys()

  Dim r As Range
  Dim m, v As Variant
  Set r = Range("A2", Cells(Rows.Count, 1).End(xlUp))
  v = r.Value
  For i = 1 To UBound(v)
    s = v(i, 1) & ".pdf"
    If InStr(s, "*") Then
      m = Application.Match(s, fArray, 0)
      If IsNumeric(m) Then
        v(i, 1) = dic(fArray(m))
      Else
        v(i, 1) = ""
      End If
    ElseIf dic.Exists(s) Then
      v(i, 1) = dic(s) 'そのファイルのあるパス名
    Else
      v(i, 1) = ""
    End If
  Next
  'シートのB列に検索結果を貼り付ける
  r.Offset(, 1).Value = v

【75091】Re:ファイル検索とリンク設定
お礼  kohaku  - 13/12/10(火) 16:32 -

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

再度ご教授頂き、お手数をお掛けいたしました。
お陰様で実現可能になりました。

VBAは奥深く色々な事が出来ると思いますので、
勉強していきます。
ありがとうございました。

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