Hello,

I am searching a "search engine".
The aim is to put it in a sheet of my active workbook and to be able to
found a record, whatever the sheet it is located, and a the end if this
record does exist, move to it.
Does such a macro exist in VBA ?

Nova

possibly look at the find command in Excel VBA help. It is a method of the
range object.

--
Regards,
Tom Ogilvy

"Nova" wrote in message
...
Hello,

I am searching a "search engine".
The aim is to put it in a sheet of my active workbook and to be able to
found a record, whatever the sheet it is located, and a the end if this
record does exist, move to it.
Does such a macro exist in VBA ?

Nova

Try this code:

'
' ######################### INPUT / OUTPUT
'
' Returns an array of filenames that match FileSpec.
' If no matching files are found, it returns False
'
Function GetFileList(cDrvPath As String, cFileSpec As String, Optional
lSearchSubFolder As Boolean = False) As Variant
Dim aFileArray() As Variant, nFileCount As Integer, aFileName() As String,
cFileName As String, nPtr As Integer, lFlag As Boolean
Dim dbs_tmp As Database, tdf_tmp As TableDef, rst_tmp As Recordset,
cFileNameRoot As String
On Error GoTo NoFilesFound
cFileName = Dir(cDrvPath, vbDirectory)
If lSearchSubFolder Then
nFileCount = 0
Set dbs_tmp = Workspaces(0).CreateDatabase(GeraNomeDataBaseLocal ,
dbLangGeneral)
Set tdf_tmp = dbs_tmp.CreateTableDef("tmp")
tdf_tmp.Fields.Append tdf.CreateField("DRIVE", dbText, 2)
tdf_tmp.Fields.Append tdf.CreateField("DIR_NAME", dbText, 255)
tdf_tmp.Fields.Append tdf.CreateField("FLAG", dbText, 1)
dbs_tmp.TableDefs.Append tdf_tmp
dbs_tmp.Execute "INSERT INTO tmp (DIR_NAME, FLAG) VALUES ('" &
cDrvPath & "', '0');", dbFailOnError
Do While True
Set rst_tmp = dbs_tmp.OpenRecordset("SELECT dir_name FROM tmp
WHERE Flag = '0';")
If rst_tmp.RecordCount = 0 Then
Exit Do
End If
cFileNameRoot = rst_tmp.Fields(0).Value
cFileName = Dir(cFileNameRoot, vbDirectory)
Do While cFileName < "" ' Loop until no more
matching files are found
If InStr(cFileName, ".") = 0 Then
If ((GetAttr(cFileNameRoot & cFileName) And vbDirectory) =
vbDirectory) Then
nFileCount = nFileCount + 1
ReDim Preserve aFileName(1 To nFileCount)
aFileName(nFileCount) = cFileNameRoot & cFileName & "\"
dbs_tmp.Execute "INSERT INTO tmp (DIR_NAME, FLAG) VALUES
('" & aFileName(nFileCount) & "', '0');", dbFailOnError
End If
End If
cFileName = Dir()
Loop
rst_tmp.Close
dbs_tmp.Execute "UPDATE tmp SET Flag = '1' WHERE dir_name = '" &
cFileNameRoot & "';", dbFailOnError
Loop
dbs_tmp.Execute "UPDATE tmp SET DRIVE = LEFT(DIR_NAME,2), DIR_NAME
= RIGHT(DIR_NAME,LEN(DIR_NAME)-2);", dbFailOnError
dbs_tmp.Close
End If

On Error GoTo 0

nFileCount = nFileCount + 1
ReDim Preserve aFileName(1 To nFileCount)
aFileName(nFileCount) = cDrvPath

nFileCount = 0
For nPtr = 1 To UBound(aFileName)
cFileName = Dir(aFileName(nPtr), vbDirectory)
Do While cFileName < "" ' Loop until no more matching files
are found
lFlag = False
If Not (cFileName = "." Or cFileName = "..") Then
Select Case True
Case cFileSpec = "*.*"
lFlag = True
Case Left(cFileSpec, 1) = "." And Len(cFileSpec) 3 And
Len(cFileName) Len(cFileSpec)
If Right(cFileName, Len(cFileSpec)) = cFileSpec Then
lFlag = True
End If
Case InStr(UCase(cFileName), UCase(Trans(cFileSpec, "*",
""))) 0
lFlag = True
End Select
End If
If lFlag Then
nFileCount = nFileCount + 1
ReDim Preserve aFileArray(1 To nFileCount)
aFileArray(nFileCount) = AchaDrvPath(aFileName(nPtr)) & cFileName
End If
cFileName = Dir()
Loop
Next
If nFileCount = 0 Then
GetFileList = ""
Else
GetFileList = aFileArray
End If
Exit Function
NoFilesFound:
GetFileList = False
MsgBox "Erro na Function GetFileList !!!"
Resume Next
End Function

"Nova" wrote:

Hello,

I am searching a "search engine".
The aim is to put it in a sheet of my active workbook and to be able to
found a record, whatever the sheet it is located, and a the end if this
record does exist, move to it.
Does such a macro exist in VBA ?

Nova