advanced help
per page, with , order by , clip by
Results of 1 - 1 of about 295 for cell filename (0.001 sec.)
cell (1170), filename (1984)
[[20110225102804]]
#score: 11157
@digest: 16e619f9fa1cbfde78e6286b34c4a243
@id: 53495
@mdate: 2011-03-23T04:46:02Z
@size: 62552
@type: text/plain
#keywords: foundpath (327045), checkedfile (281606), filesavename (187324), findfile (154598), fsosearch (153028), findrootfolder (149655), findfolder (142097), 1b1b1b1b (137188), findfilename (114418), dxf (58258), strreverse (49609), getsaveasfilename (32018), filecopy (31932), myfolder (29252), myfilename (25511), ファ (19616), vblf (17711), vbtab (15633), ァイ (15189), ォル (13028), イル (12926), ルダ (11156), momo (10786), entirerow (10514), フォ (10431), strconv (9473), ル名 (9200), pdf (9157), ヒッ (9099), myrng (8275), string (8206), ンセ (8156)
『ファイル名の変わるファイル指定』 （初心者なーくん） いつもお世話になります。教えて下さい。 例えば、 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は結合セルです） また、あるフォルダ下に複数のフォルダがあり、その1つ1つのフォルダには複数のファイルがあります。 そしてファイルは内容が変わる度にファイル名が変わります。 上のサンプルで言うと 実際のファイル名はQQ-WW-AAAA-AA△aa.PDFとQQ-WW-AAAA-AA△aa.DXFの2種類です。 B7は△aa以下を省いた状態です。（ファイルの差替えをする度にB7を入力し直す事を避ける為です。） ファイル名が変わると言うのは△aaが△bや△ccに変わると言う事です。 ここまでの設定状態は伝わりましたか? これからしたい事は、 @、ファイルをダウンロードする時に、ファイルを開きますか?、保存しますか?、キャンセル、と言うのが あると思いますがマクロで出来ますか? A、F7をクリックしたらB7のセル情報を読み取ってQQ-WW-AAAA-AA△aa.PDFのファイルを探して@の様に ファイルを開きますか?、保存しますか?、キャンセル、と言うのをしたいです。 B、H7をクリックしたらB7のセル情報を読み取ってQQ-WW-AAAA-AA△aa.DXFのファイルを探して@の違うパターンで、 保存しますか?、キャンセル、と言うのをしたいです。 不明な所があるかもしれませんが、お願いします。 Excel2003,WindowsXP （初心者なーくん） ---- 1.マクロで可能ですが思い通りの表示にしたいのならユーザーフォームを作る事になるでしょう。 MsgBoxのYesNoCancelで代用できれば簡単です。 2、3.文字連結でワイルドカードを使ってDir関数で探すようにします。 クリックしたら・・・はWorksheet_SelectionChangeイベントで。 色々書いて試してみて出来なければ、出来なかった所、どのようにわからないか 理想とする結果と現在の状況などをまた聞いてください。 （momo） ---- 叩き台だけ載せてみます。 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 （momo） ---- （momo）さん、いつもありがとうございます。 返事が遅くなりました。 サンプルコードありがとうございます。まさにこのような事をしたいのです。 1.私の例題が悪かったのか 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.>あるフォルダ下に複数のフォルダがあり、その1つ1つのフォルダには複数のファイルがあります。 を実現するには、 >Const myFolder As String = "C:¥test¥" をどのようにしたらいいですか? B列の内容事に、格納されているフォルダが違うのです。 なので、（momo）さんの例ならtestフォルダのなかを検索するようにするにはどうしたらいいですか? 4.PDFファイルを開くのはどうしたらいいですか? マクロの記録をしても記録できませんでした。 ちなみに、「別のアプリケーションで試す為」に、 Set ppApp = CreateObject("PowerPoint.Application") ppApp.Visible = True で、してみるとPowerPointは起動しました。 同じようにしてみて Set AdobeApp = CreateObject("Adobe Acrobat.Application") AdobeApp.Visible = True とすると、AciveXコンポーネントはオブジェクトを作成できません。 とでます。 1つも進んでいず質問ばかりですが教えてください。 （初心者なーくん） ---- 1. 検索条件が実ファイルに重複するのですね。 だとすれば逆に目で見て探す時にはどのような検索をされるのですか? 基本的なルールや条件がしっかりしていないとコードは組めません。 2. フォルダの構成がわからないのでなんとも言えません。 Dir関数でディレクトリを拾ってから再度ループするとか FileSystemObjectで再起処理するとか APIでSearchTreeForFileなんかを使う方法もあります。 もっとも、規則性があるならそれで判断も可能かと思います。 3. 一番簡単なのであればOSで拡張子のパスが設定されているなら ThisWorkbook.FollowHyperlink myFolder & CheckedFile なんかで開けるのではないでしょうか? （momo） ---- （momo）さん、いつもありがとうございます。 なかなか思いは伝わらないですね。 出来るだけ掘り下げて説明してみます。 このファイルは元々はハイパーリンクを付けまくったファイルです。 大分類、中分類、小分類・・・・とハイパーリンクで同シート内、もしくは別シートにリンク させてます。 最終ファイルに対しては 1.C:¥test¥Aフォルダ¥Bフォルダ¥Cフォルダ¥Dフォルダ¥ のような感じで最終ファイルのあるフォルダを開くようにして、目で同じファイル名の物を探しています。 なぜ、目で探しているかと言うと同じファイル名でPDFファイルとDXFファイルがあり 両方をコピーしたりするからです。（メールに添付したり・・・） では、最終ファイル名でフォルダを作り、そのファイル名のPDFファイルとDXFファイルだけをいれていたらいいのでは? と思われるかもしれませんが、ファイルの差替えが結構頻繁にあるので、細分化してファイルを格納（差替えの事）するのが手間になるからです。 また1つのフォルダに全ファイルを入れていると、差替えの時、探し出すのが大変です。 2.直接ファイルにハイパーリンクをしているのもあります。（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フォルダ Hフォルダ Iフォルダ Jフォルダ Kフォルダ Lフォルダ あファイル いファイル うファイル えファイル >3. OSで拡張子のパスが設定されているなら ?? ThisWorkbook.FollowHyperlink myFolder & CheckedFile で開けました。 （初心者なーくん） ---- D列、E列に情報があるのは初耳ですね、それで大分ロジックが変わります。 こういう事は必要な情報なので最初から明記してくださいね。 で、D列には必ず文字がありますか? そして「△」という文字なのですか? つまり、△以降だけが可変という事でしょうか? 逆に AA-11-1b1b△1b1b△aa というようにD列の文字をファイル名の 可変部分以外に使われている事は無いでしょうか? ハイパーリンクで構造的に選択していく過程でフォルダは決まるのですか? それとも、まったく違うルールでフォルダがあるのでしょうか? ファイル名に対して、何か規則性がありますか? （momo） ---- >D列、E列に情報があるのは初耳ですね、それで大分ロジックが変わります。 >こういう事は必要な情報なので最初から明記してくださいね。 すみません。私にとっては、ただの飾りみたいな物なので・・・。（B列に書き込んで いるとファイルの差替えの度にセル情報を書き換えないといけないから・・・。D列、 E列がなかったらファイル名とセル情報が違ってファイルがないと苦情が出る為。） >で、D列には必ず文字がありますか? >そして「△」という文字なのですか? D列には必ず「△」という文字があります。 >つまり、△以降だけが可変という事でしょうか? はい、そうです。 >逆に AA-11-1b1b△1b1b△aa というようにD列の文字をファイル名の >可変部分以外に使われている事は無いでしょうか? はい、ないです。 >ハイパーリンクで構造的に選択していく過程でフォルダは決まるのですか? >それとも、まったく違うルールでフォルダがあるのでしょうか? 階層はマチマチなのですが、大分類、中分類、小分類・・・・とあります。 例えば、今回のようなファイル大元の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 に変えればD列までを固定値としてそれ以降が可変のファイルを拾えます。 で、ハイパーリンクを開いていく過程でフォルダが決定されているのでしたら そのパス情報をどこかのセルにフォルダパスとして書いておけば簡単に出来ると思います。 でなければ、再起処理などでファイルを探す事になります。 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メソッドを調べてみましょう。 （momo） ---- ファイル名に関しては 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ステートメントでコピーする。というロジックになります。 （momo） ---- 1.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 2. 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 でやってみましたが、"見つかりませんでした"となります。 まず、動きをみたいのですが・・・。 （初心者なーくん） ---- 1. >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 のようにしてみましょう。 変数の中身がどうなっているかをローカルウィンドウなどで確認しながら コードを組むと良いですね。 2. 前回の回答で >ファイル名に関しては >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キーでステップ実行しながらローカルウインドウで変数を確認しながら やってみるとコードの動きが良くわかると思いますので試してみてください。 （momo） ---- （momo）さん、ありがとうです。 1.FileCopy CheckedFile, fileSaveName だと、書き込み出来ません。となり FileCopy myFolder & CheckedFile, fileSaveName にしたらコピーできました。 ローカルウィンドウで確認しましたがfileSaveNameに格納されている情報は同じでした。 なにが違うのですか? 2.fileFilter:="PDFファイル, *.PDF,DXFファイル, *.DXF") で選択できるようになってますが、これは飾りですよね? PDFファイルで保存処理の「いいえ」を選んだ後、名前を付けて保存の時にDXFを選んでもPDFファイルです。 コピーしてるわけですからDXFになるわけないですよね? では、DXFファイルで保存処理の「いいえ」を選んだ後、名前を付けて保存の時に PDFで、はじめ表示されているのですがDXFに自動で変わるように出来ますか? 3.>つまり、とりあえず試すのでしたら >FindFile = ActiveCell.Value & "△*.PDF" >のようにしないと出来ません。 そうでした。すみません。 ですが、それでも、"見つかりませんでした"となります。 で、 @.FindFile = ActiveCell.Value & "△*" と言うようにすると DXFファイルだけヒットします。 A.FindFile = ActiveCell.Value & "△*.DXF" と言うようにすると DXFファイルだけヒットします。 B.FindFile = ActiveCell.Value & "△*.pdf" と言うように小文字にすると pdfがヒットしました。 C.FindFile = ActiveCell.Value & "△*.dxf" と言うようにすると "見つかりませんでした"となります。 拡張子の大文字、小文字で影響があるのですか? @は両方ヒットすると思うのですが違いますか? （初心者なーくん） ---- 1.よくわかりません、FSOSearchは組み込んだ後ですか? 2.たんなる文字列ですから、選択したセル(Target)の値で条件分岐すれば 簡単に出来ると思いますよ。 3.ファイルを複数ヒットさせるのですか? それは前提条件が違いすぎます・・・ 今現在は最初にヒットしたものだけ取得しています。 複数が条件であれば、今よりはかなり複雑になりますね。 大文字、小文字は関係あります。 関係なくする為にはStrConv関数で変換してチェックする必要があります。 マル1は両方ヒットしますが、最初のファイルがヒットした段階で 次の処理に行くので次の該当ファイルは無視しています。 （momo） ---- （momo）さん、ありごとうです。 現時点までのマクロです。 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 1.このマクロで前回1の質問が発生しました。 ＞FSOSearchは組み込んだ後ですか? が問題ですかね? どのように組み込んだらいいのか・・・。 2.前回2の質問はこれから考えてみます。 3.>ファイルを複数ヒットさせるのですか? >それは前提条件が違いすぎます・・・ >今現在は最初にヒットしたものだけ取得しています。 すみません。F列とH列と検索対象分けているので1ヒットでいいです。 とりあえずのマクロで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 （momo） ---- （momo）さん、いつもありがとうございます。 まさにこれです。ありがとうございます。 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 ---- 1.Call ・・・と書く場合は()を付けます。 他にはFunctionプロシージャを呼ぶ時も。 Callを付けないで呼ぶ時は()を外します。 変数の受け渡しは基本的には順番どおりです。 2.元々そのようになっていませんか? 3.は、質問・・ではないですよね? VBAは色々な事が出来るので、その分覚える事も多いですよね。 私だって、まだまだ解らない事が山のようにあります。 （全体の1割も使いこなせていないのではないでしょうか） なので、必要な事を必要な時に色々試して追及していく。 それをやり続ける根気ですかねぇ。 難しさを楽しんで、1つの事に対するやり方が色々あるので 何が違うのか、を見ていくと楽になると思います。 頑張ってください。 （momo） ---- （momo）さん、いつもありがとうございます。 1.Callしか知らなかったのでまた1つ勉強になりました。 2.現状は、何度続けて作業しても名前を付けて保存の保存先は データを見つけたフォルダ（元々保存されているフォルダ）になっています。 （初心者なーくん） ---- 2. > fileSaveName = Application.GetSaveAsFilename(CheckedFile, _ > fileFilter:=.Value & "ファイル, *." & .Value) の部分でCheckedFileがフルパスなのでそうなってしまってましたね。 fileSaveName = Application.GetSaveAsFilename(StrReverse(Split(StrReverse(CheckedFile), "¥", 2)(0)), _ fileFilter:=.Value & "ファイル, *." & .Value) のように変更してみてください。 （momo） ---- （momo）さん、いつもありがとうございます。 できました。 ですが、 StrReverse 関数は 指定された文字列の文字の並びを逆にした文字列を返します。 Split 関数は 各要素ごとに区切られた文字列から 1 次元配列を作成し、返します。 とあるのですが、この記述でこの結果になるのは??です。 それともう1つ教えてほしいのですが、 Worksheet_SelectionChangeを使っているので複数セルを選んでしまったらエラーになるので あくまで単一セルのみイベントの対象にする場合は、どのように記述したらいいですか? 複数行、複数列を選んだらexit subみたいな、あくまで単一セルのみイベントの対象にしたいです。 （初心者なーくん） ---- > With Target の後に、 if .count>1 then exit sub と入れてみてください。 Targetのセル数が1以上なら終了します。 パスやファイル名の抜き取り方は、順を追って1つづつ見ていけば解ると思います。 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 （momo） ---- （momo）さん、いつもありがとうございます。 1.コンパイルエラー 配列がありません。 となります。 Step3 = StrReverse(Step2(0)) 2.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 > 1 Then Exit Sub ですとB列のchageは動作せず、 If Target.Count > 2 Then Exit Sub なら、希望通りの動作します。 同じエラー対策でいけるはずなのに、なぜ＞2になるか わかりますか? （初心者なーくん） ---- 1.あ、すみませんStep2だけVariant型にしてください Step2 As Variant 2.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にしないとイベントのループが 発生してしまいそうですね。 （momo） ---- （momo）さん、いつもありがとうございます。 >2.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によって差が少ないような 作りこみにするしかないのだと思います。 これにはユーザーフォームの知識が必要ですし時間もかかると思いますので 追々時間のある時に勉強しながら試していくと見識が深まって楽しくなると思います。 （momo） ---- （momo）さん、いつもありがとうございます。 >回避方法はEnableEventsしかないと思います。 わかりました。EnableEventsで対処しまくります。 >これにはユーザーフォームの知識が必要ですし時間もかかると思いますので >追々時間のある時に勉強しながら試していくと見識が深まって楽しくなると思います。 そうですね。追々チャレンジしてみます。 また質問ですが、 1.検索に要する時間は10秒から15秒かかるのですが、 （検索するファイルは共有サーバ（という表現で伝わるのかな?）にあります） もう少し早くは出来るのでしょうか? 2.その時検索終了間際に砂時計のマークがでますが、検索開始すぐに砂時計のマークを 出す事は出来ますか?（別にマークはこだわらないです。見た目検索しているのか、わからない ので、わかるようにしたいです。） 3.今回教えていただいたマクロをそれぞれのsheetに記述すればいいのでしょうが、 標準モジュール、もしくはthisworkbookの記述で簡素化する事は可能ですか? （初心者なーくん） ---- 1.ネットワーク上ですと、検索コードだけで高速化はほとんど望めません。 ファイル名が完全に解っている場合なら SearchTreeForFileなんかのAPIを使えばかなり高速になります。 また、シートを切り替えていく段階でフォルダが決定していくのなら そのフォルダをルートに探せば早くなります。 あとはたとえば、1回検索したら隠しシートにリスト化しておいて そこにあればそこからパスを取得し、無いファイルだけ検索する。 というようにすればそこそこ早くなるかもしれません。 2.ユーザーフォームにラベルで「検索中」などと表示して実行時に表示して 見つかったら消すような事を組み込んでみてはどうでしょうか 3.今回のコードはイベントを使っていますのでその部分だけにして あとは標準モジュールにする事もできますし ThisworkbookのWorkbook_SheetSelectionChangeイベントに書き換えても可能です。 その場合はRangeオブジェクトの親オブジェクトをイベントプロシージャの 引数であるShにする必要があります。 （momo）16:32修正 ---- （momo）さん、いつもありがとうございます。 2.Userform1.showで表示してても処理を続行中にするにはどうしたらいいですか? 1、3をもう少し教えてもらえますか? （初心者なーくん） ---- 2.vbModeless でShowしましょう。 >1、3をもう少し教えてもらえますか? 説明するのは大変なので、私が書いたコードを見てみてください。 ・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 と書いてみてください。 （momo） ---- （momo）さん、いつもありがとうございます。 1.今までのファイルで、 >vbModeless でShowしましょう。 という事なので >UserForm1.Show vbModeless >Unload UserForm1 を使った結果、検索終了後にユーザーフォームは消えますが、検索中はユーザーフォームは白く、 ラベルの「検索中」は表示されていませんでした。 どのようにしたらいいですか? 2.今回提示していただいたマクロは処理が早いですね。 ユーザーフォームは一瞬ですね。でも「検索中」は表示しているみたいです。 1との違いがよくわかりません。 それと、今回提示していただいたマクロを実行すると "該当ファイルがありません。", となります。 >Const FindRootFolder As String = "D:¥test¥" は、ちゃんと指定しているのですが・・・。 （初心者なーくん） ---- 1.Showの次の行に DoEvents と書いてみてください。 2.1との違いは、処理の速度もありますがファイルの検索をShellに任せているので マクロ自体の手が空いているからフォームを表示する余裕があって 元のですとマクロ自体で検索していますからフォームを表示する余裕が無いという感じでしょうか。 ファイルが見つからないですか? その時の変数FoundPath、FindRootFolder、FindFileNameはどうなっていますか? （momo） ---- （momo）さん、本当にありがとうございます。 1.DoEventsでいけました。 2. 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 に相当するような事ですかね? （初心者なーくん） ---- 2.ん〜今回のコードは大文字小文字は区別しないはずですが・・・ ネットワークパスの指定の仕方とかが原因ではないかな?と思ったのですが 公開出来ない内容のようですので確認ができません。 FindRootFolderの内容をエクスプローラーのアドレスバーに入れると フォルダーは表示されますよね? （momo） ---- とりあえず、少しでも確実に見つけられるように書き換えてみました。 標準モジュール内だけ以下のコードに差し替えてみてください。 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 （momo） ---- （momo）さん、本当にありがとうございます。 >FindRootFolderの内容をエクスプローラーのアドレスバーに入れると ""の中身で良いのですよね? >フォルダーは表示されますよね? 表示されます。 >とりあえず、少しでも確実に見つけられるように書き換えてみました。 のマクロを試しましたが同じで "該当ファイルがありません。" となります。 （初心者なーくん） ---- ん〜・・・こちらでは再現しないのですが どのファイルでやっても見つからないですか? （momo） ---- （momo）さん、長々とありがとうございます。 よくわからないのですが、 Filename : FindRootFolder * FindFileName の * はサブフォルダなどのことですよね? （初心者なーくん） ---- > Filename : FindRootFolder * FindFileName >の * はサブフォルダなどのことですよね? そうですが、最後に掲示したコードではそれは使ってません フォルダ配下のすべてのファイルをチェックするようにしたので。 （momo） ---- （momo）さん、長々とありがとうございます。 1. Const FindRootFolder As String = "C:¥test¥" にするとヒットします。 2.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") & "¥データ集¥" （momo） ---- （momo）さん、長々とありがとうございます。 デスクトップは仮ですが、 >Dim FindRootFolder As String >FindRootFolder = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "¥データ集¥" にしてみてもダメでした。 1.は GetDirAll = Split(StrConv(buf, vbUnicode), vbCrLf)(0) まで進みますが、 2.は If LOF(n) = 0 Then Exit Function までです。 （初心者なーくん） ---- そうですかぁ・・・ Killステートメントの行をコメントアウトして実行した後に "C:¥myDirBuffer.txt"のファイルの中身をメモ帳などで見るとどうなっていますか? （momo） ---- （momo）さん、ありがとうございます。 >1. Const FindRootFolder As String = "C:¥test¥" の場合はフルパスが記述されています。 >2.Const FindRootFolder As String = "C:¥Documents and Settings¥user¥デスクトップ¥データ集¥" の場合は白紙です。 （初心者なーくん） ---- 白紙という事は見つかっていないようですねぇ・・・ 私の方で再現できないので原因が掴めないでいます。 前回のFSO再起処理で可能なのであれば、 それとThisworkbook+標準モジュールへの移行したコードを 組み合わせてやってみる感じではどうでしょうか? （momo） ---- （momo）さん、ありがとうございます。 >前回のFSO再起処理で可能なのであれば、 >それとThisworkbook+標準モジュールへの移行したコードを >組み合わせてやってみる感じではどうでしょうか? というのは高速処理なしと言う事ですよね? （初心者なーくん） ---- そうですね。 ファイルがあるフォルダがハイパーリンクで選択していく過程で事前に解っているか ファイル名が確実に解ってか どちらかが解っていればもっと簡単に高速に出来るのですが 両方が解っていないのでなかなか難しいですね。 （momo） ---- （momo）さん、ありがとうございます。 ですよね。（momo）さんの方で再現できないとわかんないですよね。 私にとって一番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重にわからない物を探しているので時間がかかっているのです。 なので、最初の方で私が質問した > ハイパーリンクで構造的に選択していく過程でフォルダは決まるのですか? というのがそういう意味でした。 大分類、中分類・・・というのがフォルダ構成と同じなら最後にファイルを選択した 段階でフォルダが解っている事になりますよね? それなら簡単♪という事です。 （momo） ---- （momo）さん、ありがとうございます。 基本的にはおっしゃる通りなんです。 ただ事例として、わかりやすいように勝手にフォルダ名やファイル名が変更されていて ハイパーリンクが切れている状態になっている事が起こっていたのです。（私の 管理上の名称では・・・） と言う事で、どこかのセルに記述しとくと言うことですか? それぞれのファイルに対して1対みたいな感じですか? （初心者なーくん） ---- どこかのセルでも良いですし、なんらかの確立されたルールによって フォルダがわかるようになっていれば簡単ですね。 （momo） ---- （momo）さん、ありがとうございます。 >なんらかの確立されたルールによって >フォルダがわかるようになっていれば簡単ですね。 と言うのがよくわからないのですが、リストと言う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.地震関係により回答がかなり遅れるかもしれません。 すみませんが、よろしくお願いします。 （momo） ---- （momo）さん、ありがとうございます。 1案、2案複合でも出来ますよね?それで行きます。 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 時間が無いので簡潔ですみません。 （momo） ---- （momo）さん、ありがとうございます。 教えて下さい。 （momo）さんのマクロを実行した所、 指定されたファイルを開くことができません となります。 その時のFoundPathはFindFileNameになっています。（拡張子は小文字） それで FoundPath = FolderPath & FindFileName としてみましたが、同じく指定されたファイルを開くことができません となります。（拡張子は大文字） （初心者なーくん） ---- あ、すみません。 チェックミスですね。 ThisWorkbook.FollowHyperlink FolderPath & FoundPath に直してください。 FindFileName は探すファイル名なので「*」が含まれます。 見つかったファイル名はFoundPathに入っているので FolderPath & FoundPath となります。 （momo） ---- （momo）さん、ありがとうございます。 >数式でリンクの場合に検索できない原因は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¥ こっちのパターンの場合、A列にはどう記入しています? そのままですと、単に数式としてのリンクですよね 「=」が入っていたのでリンクしてファイル名を表示させているのだと勘違い したので質問と回答に行き違いがありました。 文字列として [1]|Sheet1!F10:H15|D:¥123¥ [2]|Sheet1!F16:H20|D:¥test¥ABC¥ のように入れないとダメです。 そしてA列ではなくて「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¥ こっちのファイル名が入っているパターンでやる方が簡単です。（それが前回のコード） （momo） ---- （momo）さん、 了解です。これでようやく思うような物が出来そうです。 ほんとに長い間教えていただきありがとうございました。 （初心者なーくん） ...
https://www.excel.studio-kazu.jp/wiki/kazuwiki/201102/20110225102804.txt - [detail] - similar
PREV NEXT
Powered by Hyper Estraier 1.4.13, with 97054 documents and 608269 words.

訪問者：カウンタValid HTML 4.01 Transitional