[[20100511194823]]　『ブックの検索』（かくれんぼ）　ページの最後に飛ぶ

『ブックの検索』（かくれんぼ）

 Excel2003 WindowsXP

 ＰＣ内にあるブックを検索し、もしなければそれを作成すると言うような
大胆なことができるマクロコードはありますか？もしあれば教えてください。
ＰＣ内には同じ名前のブックを保存していることもありますがそれが回避できれば
最高ですが、そのときはエラーが出てもＯＫです。

 ここに、全ドライブを検索してブックがあれば開く。というサンプルを載せています。
 無ければ・・・ブックを作成という所だけ変更すれば使えると思うので参考にしてください。

[[20100510122429]]　『ワークブックオープン』（はる）　

 （ｍｏｍｏ）

 確認しました。
 エラーが発生し SearchTreeForFile の部分に色付けされ「Sub又はFunctionが定義されていません。」と、表示されます。
 （かくれんぼ)

  Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
      (ByVal RootPath As String, _
       ByVal InputPathName As String, _
       ByVal OutputPathBuffer As String) As Long

 このコードが先頭にありますか？
 あと一応、標準モジュールでやってください。

 上のコードがあってエラーになる場合はコード全体を見せてください。
 （ｍｏｍｏ）

  Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
      (ByVal RootPath As String, _
       ByVal InputPathName As String, _
       ByVal OutputPathBuffer As String) As Long

 をコードの先頭に貼り付けると、その下に線が表示され、これでマクロを実行すると、
エラーが発生します。
 （かくれんぼ）

 >上のコードがあってエラーになる場合はコード全体を見せてください。

 をお願いします。
 （ｍｏｍｏ）

 コードを表示します。

 Private Sub UserForm_INITIALIZE()
    ComboBox1.List = Array("a", "b", "c", "d", "e")
End Sub
 Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
      (ByVal RootPath As String, _
       ByVal InputPathName As String, _
       ByVal OutputPathBuffer As String) As Long
 （この部分に区切り線が入ります。）
Private Sub CommandButton1_Click()
    Dim flgWB As Boolean, wb As Object

  'For Each wb In Workbooks
  '  If wb.Name = Me.TextBox1.Text Then
  '    flgWB = True
  '    Exit For
  '  End If
  'Next wb
   Dim myFolder As Object
  Dim myRootPath As String, myFind As String, myBook As String * 513
  With CreateObject("Scripting.FileSystemObject")
    For Each myFolder In .Drives
      If myFolder.DriveType = 2 Then
        myRootPath = myFolder.Path & "\"
        myFind = TextBox1.Text & ".xls" 'ComboBox2.Value & ".xls"
        If SearchTreeForFile(myRootPath, myFind, myBook) Then
          myFind = Left$(myBook, InStr(myBook, vbNullChar) - 1)
          Workbooks.Open myFind
        Exit Sub
        End If
      End If
    Next myFolder
  End With
  If flgWB = True Then
    Worksheets(ComboBox1.Text).Copy Before:=Workbooks(TextBox1.Text & ".xls").Sheets(1)
    ActiveSheet.Shapes("ボタン").Select
    Selection.Cut
    Unload UserForm1
  Else
    MsgBox "指定のブックは見つかりません｡", Title:="指定ブックの確認"
    Exit Sub
  End If
 End Sub

 以上です。
 （かくれんぼ）

 コードの中身は見ていません。

 それ以前に
 Private Sub UserForm_INITIALIZEがあるという事は
 ユーザーフォームのモジュールですよね？
 記述は標準モジュールにしてください。

 あとPrivate Declare Function・・・というAPIの宣言は
 必ずモジュールの先頭に記述してください。
 他の変数の宣言やプロシージャより上に記述する必要があります。

 以上を修正したうえで確認して、まだエラーがあるなら教えてください。
 （ｍｏｍｏ）

 Option Explicit
 Private Declare Function SearchTreeForFile Lib "imagehlp.dll" _
      (ByVal RootPath As String, _
       ByVal InputPathName As String, _
       ByVal OutputPathBuffer As String) As Long
 Sub 移動()
  Dim flgWB As Boolean, wb As Object
  Dim myFolder As Object
  Dim myRootPath As String, myFind As String, myBook As String * 513
  With CreateObject("Scripting.FileSystemObject")
    For Each myFolder In .Drives
      If myFolder.DriveType = 2 Then
        myRootPath = myFolder.Path & "\"
        myFind = "OA5571(ﾃﾞｰﾀ).xls" 'ComboBox2.Value & ".xls"
        If SearchTreeForFile(myRootPath, myFind, myBook) Then
          myFind = Left$(myBook, InStr(myBook, vbNullChar) - 1)
          Workbooks.Open myFind
        Exit Sub
        End If
      End If
    Next myFolder
  End With
  If flgWB = True Then
    Workbooks("Book1.xls").Sheets("Sheet1").Copy Before:=Workbooks("OA5571(ﾃﾞｰﾀ).xls").Sheets(1)
    ActiveSheet.Shapes("ボタン").Select
    Selection.Cut
    Unload UserForm1
  Else
    MsgBox "指定のブックは見つかりません｡", Title:="指定ブックの確認"
    Exit Sub
  End If
 End Sub

 としてみました。これでマクロを実行したら、「Book1」は表示されましたが、「Sheet1」は
移動していませんでした。
 （かくれんぼ）

 開くのであればAPI部分は大丈夫ですね。

 Sheet1の移動はflgWBがTrueの場合に実行するのですよね？
 flgWBはどこで設定してるのでしょう？どこにも見当たらないですね。
 それにmyFindのブックを開いた後にすぐExit Subしてますから
 その下のコードはブックがあった時にはまったく機能していないのでは？
 ブックが見つかって開いた時に何かをするのであればそうなるように組み替えてください。

 F8でステップ実行してみる事をお勧めします。
 （ｍｏｍｏ）

 昨日ご指摘の部分に気づき修正しテストしたところ、正常に作動するコードができました。

 If myFind = TextBox1.Text & ".xls" = True Then
    MsgBox "指定のブックはありません。ブック名を変えてください。"
    Exit Sub
  Else
    Workbooks("Book1.xls").Sheets(ComboBox1.Text).Copy Before:=Workbooks(TextBox1.Text & ".xls").Sheets(1)
    ActiveSheet.Shapes("ボタン").Select
    Selection.Cut
    Unload UserForm1
  End If

 ここで一つの疑問は、myFind = TextBox1.Text & ".xls" が正解（True)のとき、なぜElseに
飛ぶのでしょうか。間違いのときは、"指定のブックはありません。ブック名を変えてください。"に進みます。

 それと、疑問は疑問として、正常に作動するようになったので、早速、職場に持ち帰り
試してみました。すると、"指定のブックは見つかりません｡" が、表示されました。
なぜか考えてみました。解ったことは、コピー先のブックは、社内イントラで共有している
フォルダに収容しているブックであることです。この元フォルダは私の使用している
ＰＣには保存しておりません。私の使用しているＰＣに保存しているブックへの移動は
正常に行います。まだ元フォルダを保存しているＰＣではテストできていません。

 たぶん、原因はこれだと考え（間違っていたらゴメンナサイ。） For Each myFolder In .Drives
の .Drives の部分コードを変えればと思い、ネットで検索しましたが、見つかりませんでした。
解決方法があれば教えてください。
 （かくれんぼ）

 Ifの前に
 MsgBox myFind = TextBox1.Text & ".xls"
 を入れて、Trueの時、Falseの時を比較していますか。

 共有フォルダのすべてのフォルダを検索する負荷は大丈夫ですか。
 (alt)

  If myFolder.DriveType = 2 Then
 ここでローカルのハードディスクに限定して検索しています。
 ネットワークドライブに対してこのコードを使うのはお勧めできません。

 ネットワークに負荷が掛かるのは当然の事ですが、検索時間が膨大になります。
 保管されているドライブが解っているのでしたら全検索ではなく
 指定ドライブ、指定フォルダ以下をＦＳＯなどを使って再起検索するか
 上記コードでもルートフォルダを指定しなおした上で
 If分岐を外してみてください。

 （ｍｏｍｏ）

 おっしゃるように、このコードを実行するに当たっては確かに、少々重いなと感じましたが、
ＰＣ全体から検索するのでこれもやむ得ないかと思っていましたが、ネットワーク全体から
検索するとなるともっと重くなるのは解りますので、これはあきらめ、移動したいブックは
開いてから実行することにします。これであれば、以前、ｍｏｍｏさんからご指導いただいた
コードで充分対応できます。いろいろご指導有難うございました。いろんなコードがあることが
勉強でき、決して無駄なコードのご指導であったとは思いません。本当に感謝いたします。
 今後ともご指導のほどよろしくお願いいたします。
 （かくれんぼ）

コメント返信：

[ 一覧(最新更新順) ]

[[20100511194823]] 『ブックの検索』（かくれんぼ） ページの最後に飛ぶ

[[20100511194823]]　『ブックの検索』（かくれんぼ）　ページの最後に飛ぶ