[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ファイル名の変わるファイル指定』 （初心者なーくん）
いつもお世話になります。教えて下さい。
例えば、
B C F G H
7 QQ-WW-AAAA-AA PDF / DXF
8 QQ-WW-HHHH PDF / DXF
や、又は
10 TT-PP-LMLM PDF / DXF
11 TT-PP-DDDDD-KK PDF / DXF
と言うようなｼｰﾄの状態です。（B,Cは結合セルです）
また、あるフォルダ下に複数のフォルダがあり、その１つ１つのフォルダには複数のファイルがあります。 そしてファイルは内容が変わる度にファイル名が変わります。 上のサンプルで言うと 実際のファイル名はQQ-WW-AAAA-AA△aa.PDFとQQ-WW-AAAA-AA△aa.DXFの２種類です。 B7は△aa以下を省いた状態です。（ファイルの差替えをする度にB7を入力し直す事を避ける為です。） ファイル名が変わると言うのは△aaが△bや△ccに変わると言う事です。
ここまでの設定状態は伝わりましたか？
これからしたい事は、 ①、ファイルをダウンロードする時に、ファイルを開きますか？、保存しますか？、キャンセル、と言うのが あると思いますがマクロで出来ますか？ ②、F7をクリックしたらB7のセル情報を読み取ってQQ-WW-AAAA-AA△aa.PDFのファイルを探して①の様に ファイルを開きますか？、保存しますか？、キャンセル、と言うのをしたいです。 ③、H7をクリックしたらB7のセル情報を読み取ってQQ-WW-AAAA-AA△aa.DXFのファイルを探して①の違うﾊﾟﾀｰﾝで、 保存しますか？、キャンセル、と言うのをしたいです。
不明な所があるかもしれませんが、お願いします。
Excel2003,WindowsXP （初心者なーくん）
１．マクロで可能ですが思い通りの表示にしたいのならユーザーフォームを作る事になるでしょう。 MsgBoxのYesNoCancelで代用できれば簡単です。
２、３．文字連結でワイルドカードを使ってDir関数で探すようにします。 クリックしたら・・・はWorksheet_SelectionChangeイベントで。
色々書いて試してみて出来なければ、出来なかった所、どのようにわからないか 理想とする結果と現在の状況などをまた聞いてください。 （ｍｏｍｏ）
叩き台だけ載せてみます。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const myFolder As String = "D:\test\"
Dim myFileName As String, CheckedFile As String
Dim Ans As Long
With Target
If .Column = 6 Or .Column = 8 Then
Select Case .Value
Case "PDF", "DXF"
myFileName = .EntireRow.Cells(2).Value & "*." & .Value
Case Else
Exit Sub
End Select
CheckedFile = Dir(myFolder & myFileName)
If CheckedFile = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Exit Sub
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & CheckedFile & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
'開く場合の処理 フルパスは myFolder & CheckedFile
Case vbNo
'保存の場合の処理 フルパスは myFolder & CheckedFile
Case vbCancel
'キャンセルの場合の処理
End Select
End If
End If
End With
（ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。 返事が遅くなりました。 サンプルコードありがとうございます。まさにこのような事をしたいのです。
１．私の例題が悪かったのか
B C F G H
10 AA-11-1b1b1b1b PDF / DXF
11 AA-11-1b1b1b1b-A PDF / DXF
のような場合（このﾊﾟﾀｰﾝは多いです）、ローカルウィンドウで確認した時（F10をクリックした時）、
myFileName：AA-11-1b1b1b1b
CheckedFile：AA-11-1b1b1b1b-A
となります。どのように修正したらいいですか？
2．>あるフォルダ下に複数のフォルダがあり、その１つ１つのフォルダには複数のファイルがあります。
を実現するには、
>Const myFolder As String = "C:\test\"
をどのようにしたらいいですか？
B列の内容事に、格納されているフォルダが違うのです。
なので、（ｍｏｍｏ）さんの例ならtestフォルダのなかを検索するようにするにはどうしたらいいですか？
４．PDFファイルを開くのはどうしたらいいですか？
マクロの記録をしても記録できませんでした。
ちなみに、「別のアプリケーションで試す為」に、
Set ppApp = CreateObject("PowerPoint.Application")
ppApp.Visible = True
で、してみるとPowerPointは起動しました。
同じようにしてみて
Set AdobeApp = CreateObject("Adobe Acrobat.Application")
AdobeApp.Visible = True
とすると、AciveXコンポーネントはオブジェクトを作成できません。
とでます。
１つも進んでいず質問ばかりですが教えてください。
（初心者なーくん）
1. 検索条件が実ファイルに重複するのですね。 だとすれば逆に目で見て探す時にはどのような検索をされるのですか？ 基本的なルールや条件がしっかりしていないとコードは組めません。
2. フォルダの構成がわからないのでなんとも言えません。 Dir関数でディレクトリを拾ってから再度ループするとか FileSystemObjectで再起処理するとか APIでSearchTreeForFileなんかを使う方法もあります。 もっとも、規則性があるならそれで判断も可能かと思います。
3. 一番簡単なのであればOSで拡張子のパスが設定されているなら ThisWorkbook.FollowHyperlink myFolder & CheckedFile なんかで開けるのではないでしょうか？
（ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。
なかなか思いは伝わらないですね。 出来るだけ掘り下げて説明してみます。 このファイルは元々はハイパーリンクを付けまくったファイルです。 大分類、中分類、小分類・・・・とハイパーリンクで同ｼｰﾄ内、もしくは別ｼｰﾄにリンク させてます。 最終ファイルに対しては １．C:\test\Aフォルダ\Bフォルダ\Cフォルダ\Dフォルダ\ のような感じで最終ファイルのあるフォルダを開くようにして、目で同じファイル名の物を探しています。 なぜ、目で探しているかと言うと同じファイル名でPDFファイルとDXFファイルがあり 両方をコピーしたりするからです。（メールに添付したり・・・） では、最終ファイル名でフォルダを作り、そのファイル名のPDFファイルとDXFファイルだけをいれていたらいいのでは？ と思われるかもしれませんが、ファイルの差替えが結構頻繁にあるので、細分化してファイルを格納（差替えの事）するのが手間になるからです。 また１つのフォルダに全ファイルを入れていると、差替えの時、探し出すのが大変です。
２．直接ファイルにハイパーリンクをしているのもあります。（DXFファイルが必要ない時）
ここで、問題にしているのが、目で探すと言うことです。 第3者がこの問題に対してファイル名をわかりやすく書き換えたりしていて、リンクがきれたり、見つからんと苦情があるからです。 なので今回質問した内容になるのです。 伝わりましたか？
>1. 検索条件が実ファイルに重複するのですね。 ？？ 今回の例で表すとセルの状態は B C D E F G H 10 AA-11-1b1b1b1b △？ PDF/DXF 11 AA-11-1b1b1b1b-A △？ PDF/DXF 12 AA-11-2c2c2c2c △？ PDF/DXF 13 AA-11-2c2c2c2c-A △？ PDF/DXF
E列が？なのはファイルの差替えの度にE列を書き換えるのが手間だからです。 実際のファイル名
AA-11-1b1b1b1b△aa
AA-11-1b1b1b1b-A△aa
AA-11-2c2c2c2c△b
AA-11-2c2c2c2c-A△b
>2. フォルダの構成がわからないのでなんとも言えません。
>Dir関数でディレクトリを拾ってから再度ループするとか
>FileSystemObjectで再起処理するとか
>APIでSearchTreeForFileなんかを使う方法もあります。
>もっとも、規則性があるならそれで判断も可能かと思います。
Aフォルダ
Bフォルダ Cフォルダ Dフォルダ
Eフォルダ Fフォルダ Gフォルダ Ｈフォルダ Ｉフォルダ Ｊフォルダ Kフォルダ Lフォルダ あファイル いファイル うファイル えファイル
>3. OSで拡張子のパスが設定されているなら ？？ ThisWorkbook.FollowHyperlink myFolder & CheckedFile で開けました。 （初心者なーくん）
Ｄ列、Ｅ列に情報があるのは初耳ですね、それで大分ロジックが変わります。 こういう事は必要な情報なので最初から明記してくださいね。
で、Ｄ列には必ず文字がありますか？ そして「△」という文字なのですか？
つまり、△以降だけが可変という事でしょうか？
逆に AA-11-1b1b△1b1b△aa というようにＤ列の文字をファイル名の 可変部分以外に使われている事は無いでしょうか？
ハイパーリンクで構造的に選択していく過程でフォルダは決まるのですか？ それとも、まったく違うルールでフォルダがあるのでしょうか？ ファイル名に対して、何か規則性がありますか？
（ｍｏｍｏ）
>Ｄ列、Ｅ列に情報があるのは初耳ですね、それで大分ロジックが変わります。 >こういう事は必要な情報なので最初から明記してくださいね。
すみません。私にとっては、ただの飾りみたいな物なので・・・。（B列に書き込んで いるとファイルの差替えの度にセル情報を書き換えないといけないから・・・。D列、 E列がなかったらファイル名とセル情報が違ってファイルがないと苦情が出る為。）
>で、Ｄ列には必ず文字がありますか？ >そして「△」という文字なのですか？ Ｄ列には必ず「△」という文字があります。
>つまり、△以降だけが可変という事でしょうか？ はい、そうです。
>逆に AA-11-1b1b△1b1b△aa というようにＤ列の文字をファイル名の >可変部分以外に使われている事は無いでしょうか？ はい、ないです。
>ハイパーリンクで構造的に選択していく過程でフォルダは決まるのですか？ >それとも、まったく違うルールでフォルダがあるのでしょうか？ 階層はマチマチなのですが、大分類、中分類、小分類・・・・とあります。 例えば、今回のようなファイル大元の1つのフォルダにある（Aフォルダ） Aフォルダの中にメーカー別にフォルダで分かれている。（Bフォルダ（トヨタ）、 Cフォルダ（日産）、Dフォルダ（ホンダ）・・・） Bフォルダの中には型式（種類)別にフォルダに分かれている。（Eフォルダ（大型車）、 Fフォルダ（中型者）、Gフォルダ（小型車）、・・・） Eフォルダの中には品名でファイルがたくさんある。 と言った感じなので、Bのセル情報の所までハイパーリンクでどんどんフォルダを選択 して（開いてる状態です）
＞ファイル名に対して、何か規則性がありますか？ ないです。
PDF or DXFをクリックして保存を選んだ時、例えば、PDFファイルを保存したい時 どうしたらいいですか？ 自動記録では何も記録されませんでした。
（初心者なーくん）
そうですか～
ファイル名に関しては >myFileName = .EntireRow.Cells(2).Value & "*." & .Value を myFileName = .EntireRow.Cells(2).Value & .EntireRow.Cells(4).Value & "*." & .Value に変えればＤ列までを固定値としてそれ以降が可変のファイルを拾えます。
で、ハイパーリンクを開いていく過程でフォルダが決定されているのでしたら そのパス情報をどこかのセルにフォルダパスとして書いておけば簡単に出来ると思います。
でなければ、再起処理などでファイルを探す事になります。 FSOの再起プロシージャですと、こんな感じになるかと思います。
Private Sub FSOSearch(FindFolder As String, FindFile As String, FoundPath As String)
Dim f As Object
If FoundPath = "" Then
With CreateObject("Scripting.FileSystemObject").GetFolder(FindFolder)
For Each f In .Files
If f.Name Like FindFile Then
FoundPath = f.Path
Exit For
End If
Next f
For Each f In .SubFolders
FSOSearch f.Path & "\", FindFile, FoundPath
Next f
End With
End If
End Sub
（いま思いつきでタラタラと書いたのでテストしてませんが・・・） ご自身で組み込めるように試行錯誤してみてください。
>PDF or DXFをクリックして保存を選んだ時、例えば、PDFファイルを保存したい時 >どうしたらいいですか？
これは単にどこかにコピーして保存するという事ですか？ FileCopyステートメントを調べてみてください。 保存する場所を選ぶならApplication.GetSaveAsFilenameメソッドを調べてみましょう。 （ｍｏｍｏ）
ファイル名に関しては myFileName = .EntireRow.Cells(2).Value & .EntireRow.Cells(4).Value & "*." & .Value で出来ました。ありごとうございます。
せっかくマクロを教えていただいているのですが、どのような動きをするのか見たく とりあえず実行したいのですが、どうしたらうごきますか？（Privateを消したり、 引数を()の外に出したり、マクロ名変えたり・・・）
>保存する場所を選ぶならApplication.GetSaveAsFilenameメソッドを調べてみましょう を調べてきましたが、名前を変えて保存はでますが、PDFやDXFのファイルをどのようにしたら保存出来ますか？
（初心者なーくん）
再起処理を行うプロシージャですから、単独では動きません。 Privateはフォーカスの問題だけなので関係なく、 引数を出してしまったら再起Procになりません。
他のプロシージャから呼び出して使います。 呼び出し方の例は
Sub 呼び出し方() Dim 探すルートパス As String Dim 探すファイル名 As String Dim 見つかったパス As String
探すルートパス = "D:\test\" 探すファイル名 = "なんたら.PDF"
Call FSOSearch(探すルートパス, 探すファイル名, 見つかったパス)
If Len(見つかったパス) > 0 Then
MsgBox 見つかったパス
Else
MsgBox "見つかりませんでした"
End If
End Sub
のように。
>名前を変えて保存はでますが、PDFやDXFのファイルをどのようにしたら保存出来ますか？
Application.GetSaveAsFilenameは保存場所を取得はしますが、保存はしませんよ？ これはヘルプにも書いてあります。
Application.GetSaveAsFilenameで保存場所を取得して、 FileCopyステートメントでコピーする。というロジックになります。
（ｍｏｍｏ）
１．FileCopy myFolder & CheckedFile, "C:\Documents and Settings\user\デスクトップ\" & CheckedFile
でデスクトップに保存はされますが、Application.GetSaveAsFilenameとの組み合わせがよくわかりまん。
Dim fileSaveName As String
fileSaveName = Application.GetSaveAsFilename( _
fileFilter:="PDF ファイル (*.PDF), *.PDF")
FileCopy myFolder & CheckedFile, "C:\Documents and Settings\user\デスクトップ\" & CheckedFile
２． Sub 呼び出し方() Dim FindFolder As String Dim FindFile As String Dim FoundPath As String
FindFolder = "C:\test\" FindFile = ActiveCell.Value 'B列をクリックしている状態で、呼び出し方()マクロ実行する Call FSOSearch(FindFolder, FindFile, FoundPath)
If Len(FoundPath) > 0 Then
MsgBox FoundPath
Else
MsgBox "見つかりませんでした"
End If
End Sub
Private Sub FSOSearch(FindFolder As String, FindFile As String, FoundPath As String)
Dim f As Object
If FoundPath = "" Then
With CreateObject("Scripting.FileSystemObject").GetFolder(FindFolder)
For Each f In .Files
If f.Name Like FindFile Then
FoundPath = f.Path
Exit For
End If
Next f
For Each f In .SubFolders
FSOSearch f.Path & "\", FindFile, FoundPath
Next f
End With
End If
End Sub
でやってみましたが、"見つかりませんでした"となります。
まず、動きをみたいのですが・・・。
（初心者なーくん）
１． >fileSaveName = Application.GetSaveAsFilename( _ > fileFilter:="PDF ファイル (*.PDF), *.PDF") で、保存するパスを取得しているのでそれを使います。 最初はCheckedFileという変数はファイル名だけでしたが、 FSOサーチでフルパスを返すようにしているので少し変更が必要です。
Dim fileSaveName As String
fileSaveName = Application.GetSaveAsFilename(CheckedFile, _
fileFilter:="PDFファイル, *.PDF,DXFファイル, *.DXF")
If fileSaveName <> "False" Then
FileCopy CheckedFile, fileSaveName
End If
のようにしてみましょう。 変数の中身がどうなっているかをローカルウィンドウなどで確認しながら コードを組むと良いですね。
２． 前回の回答で
>ファイル名に関しては >myFileName = .EntireRow.Cells(2).Value & .EntireRow.Cells(4).Value & "*." & .Value >で出来ました。
という事だったのでご理解されたのかと思っていましたが その時のmyFileNameという変数の中身は確認してみましたか？ B列の文字列と同じではないはずです。
B列が AA-11-1b1b1b1b だとしたら 変数内は AA-11-1b1b1b1b△*.PDF のようになっているはずです。
FSOSearchプロシージャ内でLike演算子で比較していますから ワイルドカードを含めてのファイル名になるようにしてください。
つまり、とりあえず試すのでしたら FindFile = ActiveCell.Value & "△*.PDF" のようにしないと出来ません。
ただし、B列と全く同じファイル名（拡張子まで）があるのであればそのまま出来ます。
色々試してみる事をされているようですので回答していて嬉しいです。 あとは、F8キーでステップ実行しながらローカルウインドウで変数を確認しながら やってみるとコードの動きが良くわかると思いますので試してみてください。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうです。
１．FileCopy CheckedFile, fileSaveName
だと、書き込み出来ません。となり
FileCopy myFolder & CheckedFile, fileSaveName
にしたらコピーできました。
ローカルウィンドウで確認しましたがfileSaveNameに格納されている情報は同じでした。
なにが違うのですか？
２．fileFilter:="PDFファイル, *.PDF,DXFファイル, *.DXF")
で選択できるようになってますが、これは飾りですよね？
PDFファイルで保存処理の「いいえ」を選んだ後、名前を付けて保存の時にDXFを選んでもPDFファイルです。
コピーしてるわけですからDXFになるわけないですよね？
では、DXFファイルで保存処理の「いいえ」を選んだ後、名前を付けて保存の時に
PDFで、はじめ表示されているのですがDXFに自動で変わるように出来ますか？
３．>つまり、とりあえず試すのでしたら
>FindFile = ActiveCell.Value & "△*.PDF"
>のようにしないと出来ません。
そうでした。すみません。
ですが、それでも、"見つかりませんでした"となります。
で、
①．FindFile = ActiveCell.Value & "△*" と言うようにすると
DXFファイルだけヒットします。
②．FindFile = ActiveCell.Value & "△*.DXF" と言うようにすると
DXFファイルだけヒットします。
③．FindFile = ActiveCell.Value & "△*.pdf" と言うように小文字にすると
pdfがヒットしました。
④．FindFile = ActiveCell.Value & "△*.dxf" と言うようにすると
"見つかりませんでした"となります。
拡張子の大文字、小文字で影響があるのですか？
①は両方ヒットすると思うのですが違いますか？
（初心者なーくん）
１．よくわかりません、FSOSearchは組み込んだ後ですか？
２．たんなる文字列ですから、選択したセル(Target)の値で条件分岐すれば 簡単に出来ると思いますよ。
３．ファイルを複数ヒットさせるのですか？ それは前提条件が違いすぎます・・・ 今現在は最初にヒットしたものだけ取得しています。 複数が条件であれば、今よりはかなり複雑になりますね。
大文字、小文字は関係あります。 関係なくする為にはStrConv関数で変換してチェックする必要があります。
マル１は両方ヒットしますが、最初のファイルがヒットした段階で 次の処理に行くので次の該当ファイルは無視しています。
（ｍｏｍｏ）
（ｍｏｍｏ）さん、ありごとうです。
現時点までのマクロです。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const myFolder As String = "C:\test\"
Dim myFileName As String, CheckedFile As String
Dim Ans As Long
With Target
If .Column = 6 Or .Column = 8 Then
Select Case .Value
Case "PDF", "DXF"
myFileName = .EntireRow.Cells(2).Value & .EntireRow.Cells(4).Value & "*." & .Value
Case Else
Exit Sub
End Select
CheckedFile = Dir(myFolder & myFileName)
If CheckedFile = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Exit Sub
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & CheckedFile & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
'開く場合の処理 フルパスは myFolder & CheckedFile
ThisWorkbook.FollowHyperlink myFolder & CheckedFile
Case vbNo
'保存の場合の処理 フルパスは myFolder & CheckedFile
Dim fileSaveName As String
fileSaveName = Application.GetSaveAsFilename(CheckedFile, _
fileFilter:="PDFファイル, *.PDF,DXFファイル, *.DXF")
If fileSaveName <> "False" Then
FileCopy myFolder & CheckedFile, fileSaveName '★これならコピーできます
End If
Case vbCancel
'キャンセルの場合の処理
End Select
End If
End If
End With
End Sub
１．このマクロで前回１の質問が発生しました。
＞FSOSearchは組み込んだ後ですか？
が問題ですかね？
どのように組み込んだらいいのか・・・。
２．前回２の質問はこれから考えてみます。
３．>ファイルを複数ヒットさせるのですか？
>それは前提条件が違いすぎます・・・
>今現在は最初にヒットしたものだけ取得しています。
すみません。F列とH列と検索対象分けているので１ヒットでいいです。
とりあえずのマクロでPDFファイルがヒットしないのでうっかり忘れてました。
>大文字、小文字は関係あります。 >関係なくする為にはStrConv関数で変換してチェックする必要があります。 上のマクロではPDFが大文字、小文字でもヒットしているように思われます。 ローカルウィンドウで myFileName "～～～.PDF" CheckFile "～～～.pdf" となっています。
（初心者なーくん）
FSOサーチを組み込む前と後では変数の中身が違うので変わってきます。 フルパスで扱った方が楽なので。
Dir関数とLike演算子では拡張子の大文字小文字に対する挙動が違うので そのような問題も出てくるのですね。
結構頑張っておられるので、これ以上はヒントといっても殆ど答えになってしまいますから 私がテスト用に書いたものを載せてみます。
今のご自身のコードと違う部分を見つけてみてください。 testプロシージャもFSOSearchも変更しています。 細かい変更箇所もあるのでよ～く見てみてくださいね。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const myFolder As String = "D:\test\"
Dim myFileName As String, CheckedFile As String, fileSaveName As String
Dim Ans As Long
With Target
If .Column = 6 Or .Column = 8 Then
Select Case .Value
Case "PDF", "DXF"
myFileName = .EntireRow.Cells(2).Value & .EntireRow.Cells(4).Value & "*." & .Value
Case Else
Exit Sub
End Select
FSOSearch myFolder, myFileName, CheckedFile
If CheckedFile = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Exit Sub
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & CheckedFile & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
ThisWorkbook.FollowHyperlink CheckedFile
Case vbNo
fileSaveName = Application.GetSaveAsFilename(CheckedFile, _
fileFilter:=.Value & "ファイル, *." & .Value)
If fileSaveName <> "False" Then
FileCopy CheckedFile, fileSaveName
End If
Case vbCancel
'キャンセルの場合の処理
End Select
End If
End If
End With
End Sub
Private Sub FSOSearch(FindFolder As String, FindFile As String, FoundPath As String)
Dim f As Object
If FoundPath = "" Then
With CreateObject("Scripting.FileSystemObject").GetFolder(FindFolder)
For Each f In .Files
If StrConv(f.Name, vbLowerCase) Like StrConv(FindFile, vbLowerCase) Then
FoundPath = f.Path
Exit For
End If
Next f
For Each f In .SubFolders
FSOSearch f.Path & "\", FindFile, FoundPath
Next f
End With
End If
End Sub
（ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。 まさにこれです。ありがとうございます。
1.>FSOSearch myFolder, myFileName, CheckedFile の、かっこなしの表現で >Private Sub FSOSearch(FindFolder As String, FindFile As String, FoundPath As String) に変数の中身を順番に対応して受け渡しているのですか？
2.ファイルを保存する時、例えば、ﾃﾞｽｸﾄｯﾌﾟに新しいフォルダを作り、そこにファイルを保存しました。 続きでファイルを保存する時、名前を付けて保存の画面が出てきた時、先ほど作った新しいフォルダを選択している状態にするには どうしたらいいですか？
3.回答を提示してもらっているのと比較して、何とか走るコードになりました。
>大文字、小文字は関係あります。
>関係なくする為にはStrConv関数で変換してチェックする必要があります。
今回これ重要みたいですね～。（でもFSOを組み込む前は問題なかったし・・・難しいなぁ）
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const FindFolder As String = "C:\test\"
Dim FindFile As String, FoundPath As String
Dim Ans As Long
With Target
If .Column = 6 Or .Column = 8 Then
Select Case .Value
Case "PDF", "DXF"
FindFile = .EntireRow.Cells(2).Value & .EntireRow.Cells(4).Value & "*." & .Value
Case Else
Exit Sub
End Select
Call FSOSearch(FindFolder, FindFile, FoundPath)
' FoundPath = Dir(FindFolder & FindFile) ★これがあると該当ファイルがありませんとなります。
If FoundPath = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Exit Sub
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & FoundPath & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
'開く場合の処理 フルパスは FindFolder & CheckedFile
ThisWorkbook.FollowHyperlink FoundPath
' ThisWorkbook.FollowHyperlink FindFolder & FoundPath
Case vbNo
'保存の場合の処理 フルパスは FindFolder & CheckedFile
Dim fileSaveName As String
fileSaveName = Application.GetSaveAsFilename(FoundPath, _
fileFilter:="PDFファイル, *.PDF,DXFファイル, *.DXF")
If fileSaveName <> "False" Then
FileCopy FoundPath, fileSaveName
' FileCopy FindFolder & FoundPath, fileSaveName
End If
Case vbCancel
'キャンセルの場合の処理
End Select
End If
End If
End With
End Sub
Private Sub FSOSearch(FindFolder As String, FindFile As String, FoundPath As String)
Dim f As Object
If FoundPath = "" Then
With CreateObject("Scripting.FileSystemObject").GetFolder(FindFolder)
For Each f In .Files
If StrConv(f.Name, vbLowerCase) Like StrConv(FindFile, vbLowerCase) Then★これにしたら動きました。
' If f.Name Like FindFile Then
FoundPath = f.Path
Exit For
End If
Next f
For Each f In .SubFolders
FSOSearch f.Path & "\", FindFile, FoundPath
Next f
End With
End If
end sub
１．Call ・・・と書く場合は()を付けます。 他にはFunctionプロシージャを呼ぶ時も。 Callを付けないで呼ぶ時は()を外します。 変数の受け渡しは基本的には順番どおりです。
２．元々そのようになっていませんか？
３．は、質問・・ではないですよね？ VBAは色々な事が出来るので、その分覚える事も多いですよね。 私だって、まだまだ解らない事が山のようにあります。 （全体の1割も使いこなせていないのではないでしょうか） なので、必要な事を必要な時に色々試して追及していく。 それをやり続ける根気ですかねぇ。 難しさを楽しんで、１つの事に対するやり方が色々あるので 何が違うのか、を見ていくと楽になると思います。 頑張ってください。
（ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。 1.Callしか知らなかったのでまた１つ勉強になりました。
2.現状は、何度続けて作業しても名前を付けて保存の保存先は ﾃﾞｰﾀを見つけたフォルダ（元々保存されているフォルダ）になっています。
（初心者なーくん）
２．
> fileSaveName = Application.GetSaveAsFilename(CheckedFile, _ > fileFilter:=.Value & "ファイル, *." & .Value)
の部分でCheckedFileがフルパスなのでそうなってしまってましたね。
fileSaveName = Application.GetSaveAsFilename(StrReverse(Split(StrReverse(CheckedFile), "\", 2)(0)), _
fileFilter:=.Value & "ファイル, *." & .Value)
のように変更してみてください。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。 できました。 ですが、 StrReverse 関数は 指定された文字列の文字の並びを逆にした文字列を返します。 Split 関数は 各要素ごとに区切られた文字列から 1 次元配列を作成し、返します。 とあるのですが、この記述でこの結果になるのは？？です。
それともう１つ教えてほしいのですが、 Worksheet_SelectionChangeを使っているので複数セルを選んでしまったらエラーになるので あくまで単一セルのみイベントの対象にする場合は、どのように記述したらいいですか？
複数行、複数列を選んだらexit subみたいな、あくまで単一セルのみイベントの対象にしたいです。
（初心者なーくん）
> With Target
の後に、 if .count>1 then exit sub と入れてみてください。 Targetのセル数が１以上なら終了します。
パスやファイル名の抜き取り方は、順を追って１つづつ見ていけば解ると思います。
Sub パスの学習() Dim myPath As String Dim Step1 As String, Step2 As String, Step3 As String, Step4 As String
myPath = "D:\test\momo\Learning.xls " Step1 = StrReverse(myPath) Step2 = Split(Step1, "\", 2) Step3 = StrReverse(Step2(0)) Step4 = StrReverse(Step2(1))
MsgBox "元のパスは「" & myPath & "」" & vbLf & _
"StrReverseすると逆になるので「" & Step1 & "」のようになる。" & vbLf & _
"「\」でSplitすると配列変数になり、Index(0)には「" & Step2(0) & "」が入り" & vbLf & _
"Index(1)には「" & Step2(1) & "」が入る。" & vbLf & _
"このままでは逆文字なので" & vbLf & _
"ファイル名が欲しければIndex(0)をStrReverseで戻して「" & Step3 & "」になりますし" & vbLf & _
"パスだけが欲しければIndex(1)をStrReverseで戻して「" & Step4 & "」にできます。"
End Sub
（ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。 1.コンパイルエラー 配列がありません。 となります。 Step3 = StrReverse(Step2(0))
２．if .count>1 then exit sub
で、バッチリ出来ました。ありがとうございます。
ここで、また教えてほしいことがあるのですが。
（結果として後だしみたいになり申し訳ございません。）
今回、momoさんに教えてもらっている1つ前のステップとして同じsheetのB列で
Worksheet_SelectionChangeをしています。
要するに
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 2 Then Exit Sub
If Target.Column = 2 Then
If Not Application.Intersect(Target, Range("B6:B7")) Is Nothing Then
Application.Goto Reference:=Worksheets("sheet1").Range("A47"), _
Scroll:=True
Application.ScreenUpdating = False
ActiveCell.Resize(36, 26).Select
ActiveWindow.Zoom = True
ActiveCell.Select
Application.ScreenUpdating = True
End If
．
．
．
今回、momoさんに教えてもらった処理
end sub となります。
If Target.Count > １ Then Exit Sub
ですとB列のchageは動作せず、
If Target.Count > 2 Then Exit Sub
なら、希望通りの動作します。
同じエラー対策でいけるはずなのに、なぜ＞２になるか
わかりますか？
（初心者なーくん）
１．あ、すみませんStep2だけVariant型にしてください Step2 As Variant
２．B列とC列が結合されているからではないですか？ こんな感じで、列で分けてからTarget.Countの分岐を入れるとか。
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Const myFolder As String = "D:\test\"
Dim myFileName As String, CheckedFile As String, fileSaveName As String
Dim Ans As Long
With Target
Select Case .Column
Case 2
If .Count = 2 And Not Application.Intersect(Target, Range("B6:B7")) Is Nothing Then
'B列処理
End If
Case 6, 8
If .Count = 1 Then
Select Case .Value
Case "PDF", "DXF"
myFileName = .EntireRow.Cells(2).Value & .EntireRow.Cells(4).Value & "*." & .Value
Case Else
Exit Sub
End Select
FSOSearch myFolder, myFileName, CheckedFile
If CheckedFile = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Exit Sub
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & CheckedFile & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
ThisWorkbook.FollowHyperlink CheckedFile
Case vbNo
fileSaveName = Application.GetSaveAsFilename(StrReverse(Split(StrReverse(CheckedFile), "\", 2)(0)), _
fileFilter:=.Value & "ファイル, *." & .Value)
If fileSaveName <> "False" Then
FileCopy CheckedFile, fileSaveName
End If
Case vbCancel
'キャンセルの場合の処理
End Select
End If
End If
End Select
End With
End Sub
でも、このB列の処理は何をしているんでしょうか？ ScreenUpdatingをFalseにした状態でズームとかしてますが意味がわからないですし Cell領域をselectしてるので、EnableEventsをFalseにしないとイベントのループが 発生してしまいそうですね。
（ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。
>２．B列とC列が結合されているからではないですか？ あ、そういう事ですか、納得です。
>でも、このB列の処理は何をしているんでしょうか？ > ScreenUpdatingをFalseにした状態でズームとかしてますが意味がわからないですし
あぅ、momoさんの目からみて色々問題あるみたいですね。 元々は以前にも記述しましたが、ハイパーリンクしまくりのファイルです。（希望の内容が画面内に収まるように ハイパーリンク先のセルを調整しています。） ただここで問題が・・・、私のモニターと他の人のモニターサイズが違う為、内容がうまく表示されていない事に 気づいたので、selectしてzoomしまくりのマクロをたくさん作りました。 その時に、sheet移動（この時Activateでzoomしてます）の時かセル移動の時、 画面のちらつきがあり、ScreenUpdatingをFalseをいれました。 セル移動のときは意味ないですか？
>Cell領域をselectしてるので、EnableEventsをFalseにしないとイベントのループが >発生してしまいそうですね。 先ほどmomoさんの懸念されている事が起こり、今回はActivate時のselectを EnableEventsをFalseで何とか回避しました。 漠然としてますが、何か良い方法ありますか？
（初心者なーくん）
なるほど、見た目の問題でZoomしてたのですね。 であれば選択⇒切り替え⇒選択というような事をシートでやっているので 回避方法はEnableEventsしかないと思います。 （特にそれ自体が問題という訳ではありません）
根本的に、なんとかしたいという事ですと全く処理の仕方を変えて たとえばユーザーフォームなんかにして見た目にPCによって差が少ないような 作りこみにするしかないのだと思います。
これにはユーザーフォームの知識が必要ですし時間もかかると思いますので 追々時間のある時に勉強しながら試していくと見識が深まって楽しくなると思います。
（ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。 >回避方法はEnableEventsしかないと思います。 わかりました。EnableEventsで対処しまくります。
>これにはユーザーフォームの知識が必要ですし時間もかかると思いますので >追々時間のある時に勉強しながら試していくと見識が深まって楽しくなると思います。 そうですね。追々チャレンジしてみます。
また質問ですが、 １．検索に要する時間は10秒から15秒かかるのですが、 （検索するファイルは共有サーバ（という表現で伝わるのかな？）にあります） もう少し早くは出来るのでしょうか？ ２．その時検索終了間際に砂時計のマークがでますが、検索開始すぐに砂時計のマークを 出す事は出来ますか？（別にマークはこだわらないです。見た目検索しているのか、わからない ので、わかるようにしたいです。） ３．今回教えていただいたマクロをそれぞれのsheetに記述すればいいのでしょうが、 標準ﾓｼﾞｭｰﾙ、もしくはthisworkbookの記述で簡素化する事は可能ですか？
（初心者なーくん）
１．ネットワーク上ですと、検索コードだけで高速化はほとんど望めません。 ファイル名が完全に解っている場合なら SearchTreeForFileなんかのAPIを使えばかなり高速になります。 また、シートを切り替えていく段階でフォルダが決定していくのなら そのフォルダをルートに探せば早くなります。 あとはたとえば、１回検索したら隠しシートにリスト化しておいて そこにあればそこからパスを取得し、無いファイルだけ検索する。 というようにすればそこそこ早くなるかもしれません。
２．ユーザーフォームにラベルで「検索中」などと表示して実行時に表示して 見つかったら消すような事を組み込んでみてはどうでしょうか
３．今回のコードはイベントを使っていますのでその部分だけにして あとは標準モジュールにする事もできますし ThisworkbookのWorkbook_SheetSelectionChangeイベントに書き換えても可能です。 その場合はRangeオブジェクトの親オブジェクトをイベントプロシージャの 引数であるShにする必要があります。
（ｍｏｍｏ）16:32修正
（ｍｏｍｏ）さん、いつもありがとうございます。 ２．Userform1.showで表示してても処理を続行中にするにはどうしたらいいですか？
１、３をもう少し教えてもらえますか？
（初心者なーくん）
２．vbModeless でShowしましょう。
>１、３をもう少し教えてもらえますか？ 説明するのは大変なので、私が書いたコードを見てみてください。
・ThisWorkbook＋標準モジュールに対応 ・UserForm1にLabelで「実行中」を作成してあるのを前提に表示処理 ・検索の高速化（ShellでDirのオプションスイッチを使って高速に取得）
に対応しています。 UserForm1を作成してLabelを置いてください。 かなり検索が早くなっているので必要ないかもしれませんが・・・ シートモジュールのコードを消すかコメントアウトした状態にしておいて
Thisworkbookモジュールに
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
With Target
If Not Application.Intersect(Target, Sh.Range("B6:B7")) Is Nothing Then
ColumnBModule Sh
End If
If (.Column = 6 Or .Column = 8) And .Count = 1 Then
If .Value = "PDF" Or .Value = "DXF" Then
FileModule Target
End If
End If
End With
End Sub
標準モジュールに
Sub FileModule(myRng As Range) Const FindRootFolder As String = "D:\test\" Dim FindFileName As String Dim FoundPath As String Dim FileSaveName As String Dim Ans As Long
FindFileName = myRng.EntireRow.Cells(2).Value & myRng.EntireRow.Cells(4).Value & "*." & myRng.Value
UserForm1.Show vbModeless
FoundPath = GetDirAll(FindRootFolder & "*" & FindFileName)
Unload UserForm1
If FoundPath = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & FoundPath & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
ThisWorkbook.FollowHyperlink FoundPath
Case vbNo
FileSaveName = Application.GetSaveAsFilename(StrReverse(Split(StrReverse(FoundPath), "\", 2)(0)), _
fileFilter:=myRng.Value & "ファイル, *." & myRng.Value)
If FileSaveName <> "False" Then
FileCopy FoundPath, FileSaveName
End If
End Select
End If
End Sub
Sub ColumnBModule(Sh As Worksheet)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Goto Reference:=Sh.Range("A47"), Scroll:=True
ActiveCell.Resize(36, 26).Select
ActiveWindow.Zoom = True
ActiveCell.Select
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Function GetDirAll(Filename As String) As String
Const bufPath As String = "C:\myDirBuffer.txt"
Dim strCommand As String
Dim n As Long
Dim buf() As Byte
strCommand = "Dir " & Filename & " /S/B > " & bufPath
CreateObject("WScript.Shell").Run "Cmd /C " & strCommand, 7, True
n = FreeFile()
Open bufPath For Binary As n
If LOF(n) = 0 Then Exit Function
ReDim buf(1 To LOF(n))
Get #n, , buf
Close n
Kill bufPath
GetDirAll = Split(StrConv(buf, vbUnicode), vbCrLf)(0)
End Function
と書いてみてください。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、いつもありがとうございます。
１．今までのファイルで、
>vbModeless でShowしましょう。
という事なので
>UserForm1.Show vbModeless
>Unload UserForm1
を使った結果、検索終了後にユーザーフォームは消えますが、検索中はユーザーフォームは白く、
ラベルの「検索中」は表示されていませんでした。
どのようにしたらいいですか？
２．今回提示していただいたマクロは処理が早いですね。
ユーザーフォームは一瞬ですね。でも「検索中」は表示しているみたいです。
１との違いがよくわかりません。
それと、今回提示していただいたマクロを実行すると
"該当ファイルがありません。",
となります。
>Const FindRootFolder As String = "D:\test\"
は、ちゃんと指定しているのですが・・・。
（初心者なーくん）
１．Showの次の行に DoEvents と書いてみてください。
２．１との違いは、処理の速度もありますがファイルの検索をShellに任せているので マクロ自体の手が空いているからフォームを表示する余裕があって 元のですとマクロ自体で検索していますからフォームを表示する余裕が無いという感じでしょうか。
ファイルが見つからないですか？ その時の変数FoundPath、FindRootFolder、FindFileNameはどうなっていますか？
（ｍｏｍｏ）
（ｍｏｍｏ）さん、本当にありがとうございます。 １．DoEventsでいけました。
２． FindRootFolderは Const FindRootFolder As String = "D:\test\"で指定の場所を表示しています。 FindFileNameは FindFileName = myRng.EntireRow.Cells(2).Value & myRng.EntireRow.Cellsの情報と一緒です。 FoundPathは ""のままです。
今、気づいたのですが前のマクロの >If StrConv(f.Name, vbLowerCase) Like StrConv(FindFile, vbLowerCase) Then に相当するような事ですかね？ （初心者なーくん）
２．ん～今回のコードは大文字小文字は区別しないはずですが・・・ ネットワークパスの指定の仕方とかが原因ではないかな？と思ったのですが 公開出来ない内容のようですので確認ができません。 FindRootFolderの内容をエクスプローラーのアドレスバーに入れると フォルダーは表示されますよね？
（ｍｏｍｏ）
とりあえず、少しでも確実に見つけられるように書き換えてみました。 標準モジュール内だけ以下のコードに差し替えてみてください。
Sub FileModule(myRng As Range) Const FindRootFolder As String = "D:\test\" Dim FindFileName As String Dim FoundPath As String Dim FileSaveName As String Dim Ans As Long
FindFileName = myRng.EntireRow.Cells(2).Value & myRng.EntireRow.Cells(4).Value & "*." & myRng.Value
UserForm1.Show vbModeless
FoundPath = GetDirAll(FindRootFolder, FindFileName)
Unload UserForm1
If FoundPath = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & FoundPath & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
ThisWorkbook.FollowHyperlink FoundPath
Case vbNo
FileSaveName = Application.GetSaveAsFilename(StrReverse(Split(StrReverse(FoundPath), "\", 2)(0)), _
fileFilter:=myRng.Value & "ファイル, *." & myRng.Value)
If FileSaveName <> "False" Then
FileCopy FoundPath, FileSaveName
End If
End Select
End If
End Sub
Sub ColumnBModule(Sh As Worksheet)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Goto Reference:=Sh.Range("A47"), Scroll:=True
ActiveCell.Resize(36, 26).Select
ActiveWindow.Zoom = True
ActiveCell.Select
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Function GetDirAll(DirFolder As String, FindFileName As String) As String
Const bufPath As String = "C:\myDirBuffer.txt"
Dim strCommand As String
Dim n As Long
Dim buf() As Byte
Dim AryBuf As Variant
strCommand = "Dir " & DirFolder & " /S/B > " & bufPath
CreateObject("WScript.Shell").Run "Cmd /C " & strCommand, 7, True
n = FreeFile()
Open bufPath For Binary As n
If LOF(n) = 0 Then Exit Function
ReDim buf(1 To LOF(n))
Get #n, , buf
Close n
Kill bufPath
AryBuf = Split(StrConv(buf, vbUnicode), vbCrLf)
For Each c In AryBuf
If StrConv(c, vbLowerCase) Like StrConv("*" & FindFileName, vbLowerCase) Then
GetDirAll = c
Exit For
End If
Next c
End Function
（ｍｏｍｏ）
（ｍｏｍｏ）さん、本当にありがとうございます。 >FindRootFolderの内容をエクスプローラーのアドレスバーに入れると ""の中身で良いのですよね？ >フォルダーは表示されますよね？ 表示されます。 >とりあえず、少しでも確実に見つけられるように書き換えてみました。 のマクロを試しましたが同じで "該当ファイルがありません。" となります。
（初心者なーくん）
ん～・・・こちらでは再現しないのですが どのファイルでやっても見つからないですか？ （ｍｏｍｏ）
（ｍｏｍｏ）さん、長々とありがとうございます。
よくわからないのですが、 Filename : FindRootFolder * FindFileName の * はサブフォルダなどのことですよね？
（初心者なーくん）
> Filename : FindRootFolder * FindFileName >の * はサブフォルダなどのことですよね？
そうですが、最後に掲示したコードではそれは使ってません フォルダ配下のすべてのファイルをチェックするようにしたので。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、長々とありがとうございます。 １． Const FindRootFolder As String = "C:\test\" にするとヒットします。 ２．Const FindRootFolder As String = "C:\Documents and Settings\user\デスクトップ\ﾃﾞｰﾀ集\" にするとダメでした。
（初心者なーくん）
デスクトップでしたら、以下のように変更してみるとどうでしょうか？
'Const FindRootFolder As String = "C:\test\"
Dim FindRootFolder As String
FindRootFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\ﾃﾞｰﾀ集\"
（ｍｏｍｏ）
（ｍｏｍｏ）さん、長々とありがとうございます。
ﾃﾞｽｸﾄｯﾌﾟは仮ですが、
>Dim FindRootFolder As String
>FindRootFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\ﾃﾞｰﾀ集\"
にしてみてもダメでした。
１．は GetDirAll = Split(StrConv(buf, vbUnicode), vbCrLf)(0) まで進みますが、 ２．は If LOF(n) = 0 Then Exit Function までです。
（初心者なーくん）
そうですかぁ・・・ Killステートメントの行をコメントアウトして実行した後に "C:\myDirBuffer.txt"のファイルの中身をメモ帳などで見るとどうなっていますか？ （ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうございます。 >１． Const FindRootFolder As String = "C:\test\" の場合はフルパスが記述されています。 >２．Const FindRootFolder As String = "C:\Documents and Settings\user\デスクトップ\ﾃﾞｰﾀ集\" の場合は白紙です。 （初心者なーくん）
白紙という事は見つかっていないようですねぇ・・・ 私の方で再現できないので原因が掴めないでいます。
前回のFSO再起処理で可能なのであれば、 それとThisworkbook＋標準モジュールへの移行したコードを 組み合わせてやってみる感じではどうでしょうか？ （ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうございます。 >前回のFSO再起処理で可能なのであれば、 >それとThisworkbook＋標準モジュールへの移行したコードを >組み合わせてやってみる感じではどうでしょうか？ というのは高速処理なしと言う事ですよね？ （初心者なーくん）
そうですね。 ファイルがあるフォルダがハイパーリンクで選択していく過程で事前に解っているか ファイル名が確実に解ってか どちらかが解っていればもっと簡単に高速に出来るのですが 両方が解っていないのでなかなか難しいですね。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうございます。 ですよね。（ｍｏｍｏ）さんの方で再現できないとわかんないですよね。 私にとって一番Bestな処理なのですが・・・。残念です
>それとThisworkbook＋標準モジュールへの移行したコードを >組み合わせてやってみる感じではどうでしょうか？ と言う事で、下記のマクロを作って見ました。 一応動きました。（勘違いしている所があるかも知れませんが・・・）
>ファイルがあるフォルダがハイパーリンクで選択していく過程で事前に解っているか 「ファイルの保管場所が決まっているようにする」（フォルダ名、ファイル名の追加なし前提）の場合は、 どのようにすれば早くできるのですか？
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
With Target
If Not Application.Intersect(Target, Sh.Range("B8:B9")) Is Nothing Then
ColumnBModule Sh
End If
If (.Column = 6 Or .Column = 8) And .Count = 1 Then
If .Value = "PDF" Or .Value = "DXF" Then
FileModule Target
End If
End If
End With
End Sub
Sub FileModule(myRng As Range)
Const FindRootFolder As String = "C:\Documents and Settings\user\デスクトップ\ﾃﾞｰﾀ集\"
'ﾃﾞｽｸﾄｯﾌﾟは仮です（すぐにヒットしますが、本番の共有サーバではやはり遅いです。）
Dim FindFileName As String
Dim FoundPath As String
Dim fileSaveName As String
Dim Ans As Long
FindFileName = myRng.EntireRow.Cells(2).Value & myRng.EntireRow.Cells(4).Value & "*." & myRng.Value
UserForm1.Show vbModeless
DoEvents
FSOSearch FindRootFolder, FindFileName, FoundPath
Unload UserForm1
If FoundPath = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & FoundPath & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
If myRng.Value = "PDF" Then
ThisWorkbook.FollowHyperlink FoundPath
Else
MsgBox "このファイルは開く事は出来ません！「いいえ」の保存を実行して下さい！！"
End If
Case vbNo
fileSaveName = Application.GetSaveAsFilename(StrReverse(Split(StrReverse(FoundPath), "\", 2)(0)), _
fileFilter:=myRng.Value & "ファイル, *." & myRng.Value)
If fileSaveName <> "False" Then
FileCopy FoundPath, fileSaveName
End If
Case vbCancel
'キャンセルの場合の処理
End Select
End If
End Sub
Sub ColumnBModule(Sh As Worksheet)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Goto Reference:=Sh.Range("A47"), Scroll:=True
ActiveCell.Resize(36, 26).Select
ActiveWindow.Zoom = True
ActiveCell.Select
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Sub FSOSearch(FindFolder As String, FindFile As String, FoundPath As String)
Dim f As Object
If FoundPath = "" Then
With CreateObject("Scripting.FileSystemObject").GetFolder(FindFolder)
For Each f In .Files
If StrConv(f.Name, vbLowerCase) Like StrConv(FindFile, vbLowerCase) Then
FoundPath = f.Path
Exit For
End If
Next f
For Each f In .SubFolders
FSOSearch f.Path & "\", FindFile, FoundPath
Next f
End With
End If
End Sub
（初心者なーくん）
動いているという事ですし、コードはさらっとしか見てませんがたぶん大丈夫でしょう。
>「ファイルの保管場所が決まっているようにする」（フォルダ名、ファイル名の追加なし前提）の場合は、 >どのようにすれば早くできるのですか？
当初からの疑問で、いまだに解っていないのですが
ハイパーリンクで選択していきますよね？
その際に
D:\＿＿＿A＿＿＿C
｜ ｜＿D
｜
｜
｜＿B＿＿＿E
｜＿F
のようなフォルダ構成だとして
最初の選択肢で選択するとAフォルダとBフォルダを選択したのと同意で
仮にAを選択して、次の選択肢を選択する事でDフォルダを選択するような
フォルダと選択肢が連携されていれば、最終的にPDFやDXFを選択する時には
D:\A\D\ という場所にある事が確定されるので
それならファイル名だけがわからないので
変数=Dir("D:\A\D\" & "momo△*.PDF")だけでファイルを見つけられるので一瞬で終わります。
今は、たとえるなら D:\ の配下のどこかに momo△ のついた名前のわからないファイル という2重にわからない物を探しているので時間がかかっているのです。
なので、最初の方で私が質問した > ハイパーリンクで構造的に選択していく過程でフォルダは決まるのですか？ というのがそういう意味でした。
大分類、中分類・・・というのがフォルダ構成と同じなら最後にファイルを選択した 段階でフォルダが解っている事になりますよね？ それなら簡単♪という事です。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうございます。 基本的にはおっしゃる通りなんです。 ただ事例として、わかりやすいように勝手にフォルダ名やファイル名が変更されていて ハイパーリンクが切れている状態になっている事が起こっていたのです。（私の 管理上の名称では・・・） と言う事で、どこかのセルに記述しとくと言うことですか？ それぞれのファイルに対して１対みたいな感じですか？ （初心者なーくん）
どこかのセルでも良いですし、なんらかの確立されたルールによって フォルダがわかるようになっていれば簡単ですね。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうございます。 >なんらかの確立されたルールによって >フォルダがわかるようになっていれば簡単ですね。 と言うのがよくわからないのですが、リストと言うsheetを作りそこに記述すると言うのでいいですか？ （初心者なーくん）
探すファイルとフォルダの関連が取れていれば大丈夫です。
|[A] |[B]
[1]|AA-11-1b1b1b1b |D:\123\
[2]|AA-11-1b1b1b1b-A|D:\test\ABC\
[3]|AA-11-2c2c2c2c |D:\try\cde\
[4]|AA-11-2c2c2c2c-A|D:\
のようにファイルごとのフォルダの形でもいいですし
|[A] |[B]
[1]|Sheet1!F10:H15|D:\123\
[2]|Sheet1!F16:H20|D:\test\ABC\
[3]|Sheet2!F10:H12|D:\try\cde\
[4]|Sheet2!F13:H20|D:\
のようにセル範囲とのフォルダの関連でも構いません。
PS.地震関係により回答がかなり遅れるかもしれません。 すみませんが、よろしくお願いします。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうございます。 １案、２案複合でも出来ますよね？それで行きます。 Findですよね？調べてみます。 （初心者なーくん）大変な時に回答ありがとうございます
教えて下さい。
あるsheet(sheet3)のレイアウトは
B C D E F G H
10 AA-11-1b1b1b1b △ ？ PDF/DXF
11 AA-11-1b1b1b1b-A △ ？ PDF/DXF
12 AA-11-2c2c2c2c △ ？ PDF/DXF
13 AA-11-2c2c2c2c-A △ ？ PDF/DXF
sheet(ﾘｽﾄ)は
[A] [B]
[1] AA-11-1b1b1b1b |D:\123\
[2] AA-11-1b1b1b1b-A |D:\test\ABC\
[3] AA-11-2c2c2c2c |D:\try\cde\
[4] AA-11-2c2c2c2c-A |D:\
の時、例えばsheet3のB11を選択しマクロを実行するとﾘｽﾄsheetのB2をselectする所まで出来ました。
Sub 検索1()
Dim FindStr As String
Dim myRnga As Range
FindStr = ActiveCell
Application.EnableEvents = False
Application.Goto Reference:=Worksheets("ﾘｽﾄ").Range("A1"), Scroll:=True
With Worksheets("ﾘｽﾄ")
With .Columns("A")
Set myRnga = .Find(What:=FindStr, LookAt:=xlWhole, _
SearchOrder:=xlByColumns, MatchByte:=False)
End With
If myRnga Is Nothing Then ' Exit Sub
MsgBox "検索に失敗しました"
Else
myRnga.Offset(0, 1).Activate
End If
End With
Application.EnableEvents = True
End Sub
また、sheet(ﾘｽﾄ)が
[1]|=Sheet3!A2 |D:\123\
や
[2]|=Sheet3!A3:A20 |D:\test\ABC\
のときは出来ませんでした。
どのようにしたらいいですか？
そしてどのように組み込んだらいいですか？
（初心者なーくん）
数式でリンクの場合に検索できない原因はFindメソッドのLookAtを省略しているからですね。 xlValuesを指定しないと検索にヒットしません。 以下のように組み込んでみてください。
'Thisworkbook モジュール
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
With Target
If Not Application.Intersect(Target, Sh.Range("B6:B7")) Is Nothing Then
ColumnBModule Sh
End If
If (.Column = 6 Or .Column = 8) And .Count = 1 Then
If .Value = "PDF" Or .Value = "DXF" Then
検索 Target
End If
End If
End With
End Sub
'標準モジュール
Sub 処理(myRng As Range, FolderPath As String)
Dim FindFileName As String
Dim FoundPath As String
Dim FileSaveName As String
Dim Ans As Long
FindFileName = myRng.EntireRow.Cells(2).Value & myRng.EntireRow.Cells(4).Value & "*." & myRng.Value
FoundPath = Dir(FolderPath & FindFileName)
If FoundPath = "" Then
MsgBox "該当ファイルがありません。", vbExclamation
Else
Ans = MsgBox("ファイルが見つかりました。" & vbLf & _
"ファイル名 ： " & FoundPath & vbLf & vbLf & _
"ファイルを開く" & vbTab & "： はい" & vbLf & _
"ファイルを保存" & vbTab & "： いいえ" & vbLf & _
"処理を中止する" & vbTab & "： キャンセル" & vbLf & vbLf & _
"を押してください。", vbYesNoCancel)
Select Case Ans
Case vbYes
ThisWorkbook.FollowHyperlink FoundPath
Case vbNo
FileSaveName = Application.GetSaveAsFilename(StrReverse(Split(StrReverse(FoundPath), "\", 2)(0)), _
fileFilter:=myRng.Value & "ファイル, *." & myRng.Value)
If FileSaveName <> "False" Then
FileCopy FoundPath, FileSaveName
End If
End Select
End If
End Sub
Sub 検索(myRng As Range)
Dim FoundRng As Range
With Worksheets("ﾘｽﾄ").Columns("A")
Set FoundRng = .Find(myRng.EntireRow.Cells(2).Value, .Cells(.Cells.Count), _
xlValues, xlWhole, xlByRows, xlNext, False)
End With
If FoundRng Is Nothing Then ' Exit Sub
MsgBox "リストと一致しません"
Else
処理 myRng, FoundRng.Offset(, 1).Value
End If
End Sub
Sub ColumnBModule(Sh As Worksheet)
With Application
.ScreenUpdating = False
.EnableEvents = False
.Goto Reference:=Sh.Range("A47"), Scroll:=True
ActiveCell.Resize(36, 26).Select
ActiveWindow.Zoom = True
ActiveCell.Select
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
時間が無いので簡潔ですみません。 （ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうございます。 教えて下さい。 （ｍｏｍｏ）さんのマクロを実行した所、 指定されたファイルを開くことができません となります。 その時のFoundPathはFindFileNameになっています。（拡張子は小文字） それで FoundPath = FolderPath & FindFileName としてみましたが、同じく指定されたファイルを開くことができません となります。（拡張子は大文字） （初心者なーくん）
あ、すみません。 チェックミスですね。
ThisWorkbook.FollowHyperlink FolderPath & FoundPath
に直してください。
FindFileName は探すファイル名なので「*」が含まれます。 見つかったファイル名はFoundPathに入っているので FolderPath & FoundPath となります。
（ｍｏｍｏ）
（ｍｏｍｏ）さん、ありがとうございます。 >数式でリンクの場合に検索できない原因はFindメソッドのLookAtを省略しているからですね。 >xlValuesを指定しないと検索にヒットしません。 >以下のように組み込んでみてください。 とのことですが、ヒットしませんでした。
sheet(ﾘｽﾄ)が [1]|=Sheet3!A2 |D:\123\ のときは、該当ファイルがありません となります。 [2]|=Sheet3!A3:A20 |D:\test\ABC\ のときは、ﾘｽﾄと一致しません となります。 （初心者なーくん）
あ、全然違う事書いてましたね。 今までの回答は
[A] [B]
[1] AA-11-1b1b1b1b |D:\123\
[2] AA-11-1b1b1b1b-A |D:\test\ABC\
[3] AA-11-2c2c2c2c |D:\try\cde\
[4] AA-11-2c2c2c2c-A |D:\
このパターンでの回答です。
[1]|=Sheet3!A2 |D:\123\ [2]|=Sheet3!A3:A20 |D:\test\ABC\
こっちのパターンの場合、Ａ列にはどう記入しています？ そのままですと、単に数式としてのリンクですよね 「=」が入っていたのでリンクしてファイル名を表示させているのだと勘違い したので質問と回答に行き違いがありました。
文字列として [1]|Sheet1!F10:H15|D:\123\ [2]|Sheet1!F16:H20|D:\test\ABC\ のように入れないとダメです。
そしてＡ列ではなくて「PDFやDXF」の入っている範囲
つまりセルを選択した時のTargetの範囲を文字として記入します。
なのでF列からH列になりますね。
そしてFindではなくてリスト範囲をループして
Range("Sheet1!F10:H15")とTargetとのIntersectの結果から
どの行に該当するかをチェックする事になります。
ファイル名のように直接検索できないので面倒になりますね。
なるべくなら [1] AA-11-1b1b1b1b |D:\123\ [2] AA-11-1b1b1b1b-A |D:\test\ABC\ こっちのファイル名が入っているパターンでやる方が簡単です。（それが前回のコード）
（ｍｏｍｏ）
（ｍｏｍｏ）さん、 了解です。これでようやく思うような物が出来そうです。 ほんとに長い間教えていただきありがとうございました。 （初心者なーくん）
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.