Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
9837 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【25185】文字列検索 masa 05/5/24(火) 0:02 質問[未読]
【25204】Re:文字列検索 小僧 05/5/24(火) 11:21 回答[未読]
【25206】Re:文字列検索 G-Luck 05/5/24(火) 11:51 発言[未読]
【25185】文字列検索
質問  masa E-MAIL  - 05/5/24(火) 0:02 -
引用なし
パスワード
   はじめまして。以下のようにファイル内の全シートを文字列検索
するものですが、schRg.Findでエラーコード1004findを設定できません。
とエラーになります。かなりおおくのシートから検索するのでオーバ
フローかと思いましたがよくわかりません。
シートが多い場合と行、列がおおい場合によくエラーが出ています。

どなたかおしえていただけないでしょうか？


Dim fn As Variant
Dim fnn As Variant

Dim schSheet As String '検索シート
　　Dim schColumns As String '検索列
　　Dim schRg As Range '検索範囲
　　Dim schWhat As String '検索文字
　　Dim fndCell As Range '検索したセル
　　Dim fstRow As Long '検索したセルの行
　　Dim fstColumn As Integer '検索したセルの列
　　Dim cntx As Integer
　　 Dim aa As Integer
　　 Dim ken As Variant
　　 Dim fnd As Integer
　　
　　 Dim pp As Variant


　Dim objsh As Worksheet
　

txt = InputBox("ファイル形式 xls")
If txt = "" Then
GoTo endr
End If

schWhat = InputBox("検索文字を入力して下さい。")
If schWhat = "" Then
GoTo endr
End If


fn = Dir("c:\m\*.xls")
Do While fn <> ""
Workbooks.Open "c:\m\" & fn


　　　　aa = Worksheets.Count
　　　　fnd = 0
　　　　cntx = 0
　　
　　　　Set objsh = Worksheets.Add(After:=Worksheets(aa))
　　　　' シート名を設定する
　　　　objsh.Name = "dummy"


　 For ii = 1 To aa
　　 Worksheets(ii).Select

　　'検索範囲をセット
　　Set schRg = Cells


　　Set fndCell = schRg.SpecialCells(xlLastCell)

　　'検索開始
　　Set fndCell = schRg.Find(What:=schWhat, After:=fndCell, LookIn:=xlFormulas, _
　　　　　　　　LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
　　　　　　　　MatchCase:=False, MatchByte:=False)
　　'見つかった！
　　　If Not (fndCell Is Nothing) Then
　　　　
　　　　fstRow = fndCell.Row
　　　　fstColumn = fndCell.Column
　　　　Do
　　　　　　cntx = cntx + 1
　　　　　　fnd = 1
　　　　　　'MsgBox "ありました！ " & fndCell.Address
　　　　　　Sheets("dummy").Select
　　　　　　Sheets("dummy").Range("a" & cntx).Value = fn
　　　　　　pp = InStr(1, fn, ".", vbTextCompare)
　　　　　　ken = Left(fn, pp - 1)
　　　　　　Sheets("dummy").Range("b" & cntx).Value = Worksheets(ii).Name
　　　　　　Sheets("dummy").Range("c" & cntx).Value = fndCell.Address
　　　　　　Worksheets(ii).Select
　　　　　　
　　　　　　 Set fndCell = schRg.FindNext(After:=fndCell)
　　　　　　　Worksheets(ii).Select
　　　　　　'最初に見つかったセルを再度見つけるまで続ける
　　　　Loop Until (fndCell.Row = fstRow) And (fndCell.Column = fstColumn)
　　　End If
　　Next
　　
　　　If fnd = 1 Then
　　　　fnn = "c:\log\" & ken & "log" & ".csv"
　　　　Application.DisplayAlerts = False
　　　　ActiveWorkbook.SaveAs Filename:=fnn
　　　　ActiveWorkbook.Close SaveChanges:=False
　　 Else
　　　　ActiveWorkbook.Close SaveChanges:=False

　　　End If
【25204】Re:文字列検索
回答  小僧  - 05/5/24(火) 11:21 -
引用なし
パスワード
   ▼masa さん：
こんにちは。

ご提示されたコードですと、コンパイルエラー等のため
「Find」のエラーにたどりつけません…。
こんな感じのコードなのでしょうか？

Sub Logフォルダへ()
Dim fn As Variant
Dim fnn As Variant
Dim schWhat As String '検索文字
Dim fndCell As Range '検索したセル
Dim cntx As Integer
Dim objsh As Worksheet
Dim myPath As String
Dim mySheet As Worksheet
Dim FirstAddress As String
Dim FndFLG As Boolean
Dim LogPath As String
　　
　　Application.ScreenUpdating = False
　　
　　myPath = "C:\m\"
　　LogPath = "c:\log\
　　
　　schWhat = InputBox("検索文字を入力して下さい。")
　　If schWhat = "" Then Exit Sub

　　fn = Dir(myPath & "*.xls")
　　
　　Do While fn <> ""
　　　　
　　　　FndFLG = False
　　　　Workbooks.Open myPath & fn
　　
　　　　For Each mySheet In ActiveWorkbook.Sheets
　　　　
　　　　With mySheet.Cells
　　　　　　Set fndCell = .Find(schWhat, LookIn:=xlValues)
　　　
　　　　　　If Not fndCell Is Nothing Then
　　　　　　Set objsh = Worksheets.Add _
　　　　　　　　　　　　(After:=Worksheets(Worksheets.Count))
　　　　　　　　objsh.Name = "dummy"
　　　　　　　　FndFLG = True
　　　　　　　　FirstAddress = fndCell.Address
　　　　　　　　cntx = 0
　　　　　　　　Do
　　　　　　　　　　With objsh
　　　　　　　　　　　　.Range("A1").Offset(0, cntx).Value = fn
　　　　　　　　　　　　.Range("A2").Offset(0, cntx).Value = mySheet.Name
　　　　　　　　　　　　.Range("A3").Offset(0, cntx).Value = fndCell.Address
　　　　　　　　　　End With
　　　　　　　　　　Set fndCell = .FindNext(fndCell)
　　　　　　　　　　cntx = cntx + 1
　　　　　　　　Loop While Not fndCell Is Nothing And fndCell.Address <> FirstAddress
　　
　　　　　　End If
　　　　End With
　　Next
　
　 If FndFLG Then
　　　　fnn = LogPath & Left(fn, (Len(fn) - 4)) & ".csv"
　　　　Application.DisplayAlerts = False
　　　　ActiveWorkbook.SaveAs Filename:=fnn
　　End If
　　　　ActiveWorkbook.Close SaveChanges:=False
fn = Dir()
Loop

Application.ScreenUpdating = True
Set objsh = Nothing
MsgBox "終了"
End Sub
【25206】Re:文字列検索
発言  G-Luck  - 05/5/24(火) 11:51 -
引用なし
パスワード
   ▼小僧 さん　▼masa さん
こんにちは

シートを保護していると、Findが失敗するようです。

あるいは、
問題が出たシートのデータを減らして実行してみたり、
シート数を減らして実行してみてはいかがですか？
問題が見えてくるかもしれません。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
9837 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free