Excel VBA質問箱 IV

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

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


51368 / 76732 ←次へ | 前へ→

【30234】Re:テキストはきだしについて
発言  ponpon  - 05/10/22(土) 23:31 -

引用なし
パスワード
   ▼MS−07B さん:
こんばんは。
作ってみました。

マクロの書いてあるブックのシート1のA1に書かれた文字を検索し、
B列にファイル名、C列にシート名を書き出します。

ファイルを開いて、検索してますので、ファイル数やシート数が多いと
時間がかかると思います。

検索するフォルダや検索する文字の場所は適宜変えてください。
もっと速い方法は、上級者の回答をお待ちください。

Sub test2()

  Dim FSO As Object
  Dim FL As Object
  Dim SH As Worksheet
  Dim FR As Range
  
  Application.ScreenUpdating = False
  Set FSO = CreateObject("scripting.filesystemobject")
  With ThisWorkbook.Worksheets("Sheet1")
   .Range("B:C").ClearContents
   .Range("B1:C1").Value = Array("ファイル名", "シート名")
   If .Range("A1").Value <> "" Then
    For Each FL In FSO.getfolder("D:\文書\test\").Files
      If Right(FL, 3) = "xls" Then
       Workbooks.Open Filename:=FL
       For Each SH In Workbooks(FL.Name).Worksheets
        Set FR = SH.Cells.Find(What:=.Range("A1").Value, LookAt:=xlPart)
        If Not FR Is Nothing Then
         .Range("B65536").End(xlUp).Offset(1).Value = FL.Name
         .Range("C65536").End(xlUp).Offset(1).Value = SH.Name
        End If
       Next
       Workbooks(FL.Name).Close False
      End If
     Next
   Else
   MsgBox "検索する文字をA1に入力してください。"
   End If
  End With
  Set FSO = Nothing
  Application.ScreenUpdating = True

End Sub

1 hits

【30232】テキストはきだしについて MS−07B 05/10/22(土) 21:43 質問
【30234】Re:テキストはきだしについて ponpon 05/10/22(土) 23:31 発言
【30244】Re:テキストはきだしについて MS−07B 05/10/23(日) 22:43 お礼

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