|
▼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
|
|