Help to improve macro

Hi
I found this cool macro on this group that makes a list of all files in
a folder. With each file name in a separate row. I would be very
grateful if any one can make suitable changes so that each row contains
a hyper link to the file.
TIA

Unni

Sub ListIndexFiles()
'Lists all file names in the folder on the active sheet
Dim FileName As String
Dim r As Integer

'Range("a2:a5").ClearContents

r = 2
With Application.FileSearch
.NewSearch
.LookIn = "C:\Documents and Settings\Administrator\My
Documents"
.FileName = "*.doc"
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
FileName = Mid(.FoundFiles(i), 18)
Cells(r, 1) = FileName
r = r + 1
Next i
End If
End With
End Sub

Opps!
also can it look in all sub-folders of "C:\Documents and
Settings\Administrator\My Documents"

TIA

Unni


unni5959 wrote:
> Hi
> I found this cool macro on this group that makes a list of all files in
> a folder. With each file name in a separate row. I would be very
> grateful if any one can make suitable changes so that each row contains
> a hyper link to the file.
> TIA
>
> Unni
>
> Sub ListIndexFiles()
> 'Lists all file names in the folder on the active sheet
> Dim FileName As String
> Dim r As Integer
>
> 'Range("a2:a5").ClearContents
>
> r = 2
> With Application.FileSearch
> .NewSearch
> .LookIn = "C:\Documents and Settings\Administrator\My
> Documents"
> .FileName = "*.doc"
> If .Execute() > 0 Then
> For i = 1 To .FoundFiles.Count
> FileName = Mid(.FoundFiles(i), 18)
> Cells(r, 1) = FileName
> r = r + 1
> Next i
> End If
> End With
> End Sub

Hi Unni,

Try:

'<<===========================

Public Sub ListIndexFiles()

'// Lists all file names in the folder and sub-folders on the
'// active sheet and inserts a hyperlink to the returned files

Dim FName As String
Dim r As Integer
Dim i As Long
Dim myPath As String
Const strFileType As String = "xls" '<<===== CHANGE
With ActiveSheet.Columns(1)
..Hyperlinks.Delete
..ClearContents
End With

myPath = "C:\Documents and Settings\" & _
"Administrator\MyDocuments"

r = 2
With Application.FileSearch
.NewSearch
.LookIn = myPath
.SearchSubFolders = True
.FileName = "*." & strFileType
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
FName = Mid(.FoundFiles(i), 1)
Cells(r, 1) = Mid(FName, Len(myPath) + 1, 255)

ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 1), _
Address:=FName, _
TextToDisplay:=Cells(r, 1).Value
r = r + 1
Next i
End If
End With
End Sub
'<<===========================


---
Regards,
Norman



"unni5959" <[email protected]> wrote in message
news:[email protected]...
> Opps!
> also can it look in all sub-folders of "C:\Documents and
> Settings\Administrator\My Documents"
>
> TIA
>
> Unni
>
>
> unni5959 wrote:
>> Hi
>> I found this cool macro on this group that makes a list of all files in
>> a folder. With each file name in a separate row. I would be very
>> grateful if any one can make suitable changes so that each row contains
>> a hyper link to the file.
>> TIA
>>
>> Unni
>>
>> Sub ListIndexFiles()
>> 'Lists all file names in the folder on the active sheet
>> Dim FileName As String
>> Dim r As Integer
>>
>> 'Range("a2:a5").ClearContents
>>
>> r = 2
>> With Application.FileSearch
>> .NewSearch
>> .LookIn = "C:\Documents and Settings\Administrator\My
>> Documents"
>> .FileName = "*.doc"
>> If .Execute() > 0 Then
>> For i = 1 To .FoundFiles.Count
>> FileName = Mid(.FoundFiles(i), 18)
>> Cells(r, 1) = FileName
>> r = r + 1
>> Next i
>> End If
>> End With
>> End Sub
>

Here is a different way, using FSO instead of the flaky FileSearch. It also
searches down into sub-folders and indents the levels.
Option Explicit

Private cnt As Long
Private arfiles
Private level As Long

Sub Folders()
Dim i As Long
Dim sFolder As String
Dim iStart As Long
Dim iEnd As Long
Dim fOutline As Boolean

arfiles = Array()
cnt = -1
level = 1

sFolder = "E:\"
ReDim arfiles(2, 0)
If sFolder <> "" Then
SelectFiles sFolder
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("Files").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Worksheets.Add.Name = "Files"
With ActiveSheet
For i = LBound(arfiles, 2) To UBound(arfiles, 2)
If arfiles(0, i) = "" Then
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If
With .Cells(i + 1, arfiles(2, i))
.Value = arfiles(1, i)
.Font.Bold = True
End With
iStart = i + 1
iEnd = iStart
fOutline = False
Else
.Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
Address:=arfiles(0, i), _
TextToDisplay:=arfiles(1, i)
iEnd = iEnd + 1
fOutline = True
End If
Next
.Columns("A:Z").ColumnWidth = 5
End With
End If
'just in case there is another set to group
If fOutline Then
Rows(iStart + 1 & ":" & iEnd).Rows.Group
End If

Columns("A:Z").ColumnWidth = 5
ActiveSheet.Outline.ShowLevels RowLevels:=1
ActiveWindow.DisplayGridlines = False

End Sub

'-----------------------------------------------------------------------
Sub SelectFiles(Optional sPath As String)
'-----------------------------------------------------------------------
Static FSO As Object
Dim oSubFolder As Object
Dim oFolder As Object
Dim oFile As Object
Dim oFiles As Object
Dim arPath

If FSO Is Nothing Then
Set FSO = CreateObject("SCripting.FileSystemObject")
End If

If sPath = "" Then
sPath = CurDir
End If

arPath = Split(sPath, "\")
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = ""
arfiles(1, cnt) = arPath(level - 1)
arfiles(2, cnt) = level

Set oFolder = FSO.GetFolder(sPath)
Set oFiles = oFolder.Files
For Each oFile In oFiles
cnt = cnt + 1
ReDim Preserve arfiles(2, cnt)
arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
arfiles(1, cnt) = oFile.Name
arfiles(2, cnt) = level + 1
Next oFile

level = level + 1
For Each oSubFolder In oFolder.Subfolders
SelectFiles oSubFolder.Path
Next
level = level - 1

End Sub

#If VBA6 Then
#Else
'-----------------------------**-----------------------------*-*------
Function Split(Text As String, _
Optional Delimiter As String = ",") As Variant
'-----------------------------**-----------------------------*-*------
Dim i As Long
Dim sFormula As String
Dim aryEval
Dim aryValues

If Delimiter = vbNullChar Then
Delimiter = Chr(7)
Text = Replace(Text, vbNullChar, Delimiter)
End If

sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") &
"""}"
aryEval = Evaluate(sFormula)
ReDim aryValues(0 To UBound(aryEval) - 1)
For i = 0 To UBound(aryValues)
aryValues(i) = aryEval(i + 1)
Next

Split = aryValues

End Function

'---------------------------------------------------------------------------
Public Function InStrRev(stringcheck As String, _
ByVal stringmatch As String, _
Optional ByVal start As Long = -1)
'---------------------------------------------------------------------------
Dim iStart As Long
Dim iLen As Long
Dim i As Long

If iStart = -1 Then
iStart = Len(stringcheck)
Else
iStart = start
End If

iLen = Len(stringmatch)

For i = iStart To 1 Step -1
If Mid(stringcheck, i, iLen) = stringmatch Then
InStrRev = i
Exit Function
End If
Next i
InStrRev = 0
End Function
'-----------------------------------------------------------------
#End If


--

HTH

RP
(remove nothere from the email address if mailing direct)


"unni5959" <[email protected]> wrote in message
news:[email protected]...
> Hi
> I found this cool macro on this group that makes a list of all files in
> a folder. With each file name in a separate row. I would be very
> grateful if any one can make suitable changes so that each row contains
> a hyper link to the file.
> TIA
>
> Unni
>
> Sub ListIndexFiles()
> 'Lists all file names in the folder on the active sheet
> Dim FileName As String
> Dim r As Integer
>
> 'Range("a2:a5").ClearContents
>
> r = 2
> With Application.FileSearch
> .NewSearch
> .LookIn = "C:\Documents and Settings\Administrator\My
> Documents"
> .FileName = "*.doc"
> If .Execute() > 0 Then
> For i = 1 To .FoundFiles.Count
> FileName = Mid(.FoundFiles(i), 18)
> Cells(r, 1) = FileName
> r = r + 1
> Next i
> End If
> End With
> End Sub
>

Hi Bob,

> Here is a different way, using FSO instead of the flaky FileSearch. It
> also
> searches down into sub-folders and indents the levels.

Given the reported Filesearch problems and the indentation, its ..... "Slam
Dunk!"

---
Regards,
Norman



"Bob Phillips" <[email protected]> wrote in message
news:[email protected]...
> Here is a different way, using FSO instead of the flaky FileSearch. It
> also
> searches down into sub-folders and indents the levels.
> Option Explicit
>
> Private cnt As Long
> Private arfiles
> Private level As Long
>
> Sub Folders()
> Dim i As Long
> Dim sFolder As String
> Dim iStart As Long
> Dim iEnd As Long
> Dim fOutline As Boolean
>
> arfiles = Array()
> cnt = -1
> level = 1
>
> sFolder = "E:\"
> ReDim arfiles(2, 0)
> If sFolder <> "" Then
> SelectFiles sFolder
> Application.DisplayAlerts = False
> On Error Resume Next
> Worksheets("Files").Delete
> On Error GoTo 0
> Application.DisplayAlerts = True
> Worksheets.Add.Name = "Files"
> With ActiveSheet
> For i = LBound(arfiles, 2) To UBound(arfiles, 2)
> If arfiles(0, i) = "" Then
> If fOutline Then
> Rows(iStart + 1 & ":" & iEnd).Rows.Group
> End If
> With .Cells(i + 1, arfiles(2, i))
> .Value = arfiles(1, i)
> .Font.Bold = True
> End With
> iStart = i + 1
> iEnd = iStart
> fOutline = False
> Else
> .Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)), _
> Address:=arfiles(0, i), _
> TextToDisplay:=arfiles(1, i)
> iEnd = iEnd + 1
> fOutline = True
> End If
> Next
> .Columns("A:Z").ColumnWidth = 5
> End With
> End If
> 'just in case there is another set to group
> If fOutline Then
> Rows(iStart + 1 & ":" & iEnd).Rows.Group
> End If
>
> Columns("A:Z").ColumnWidth = 5
> ActiveSheet.Outline.ShowLevels RowLevels:=1
> ActiveWindow.DisplayGridlines = False
>
> End Sub
>
> '-----------------------------------------------------------------------
> Sub SelectFiles(Optional sPath As String)
> '-----------------------------------------------------------------------
> Static FSO As Object
> Dim oSubFolder As Object
> Dim oFolder As Object
> Dim oFile As Object
> Dim oFiles As Object
> Dim arPath
>
> If FSO Is Nothing Then
> Set FSO = CreateObject("SCripting.FileSystemObject")
> End If
>
> If sPath = "" Then
> sPath = CurDir
> End If
>
> arPath = Split(sPath, "\")
> cnt = cnt + 1
> ReDim Preserve arfiles(2, cnt)
> arfiles(0, cnt) = ""
> arfiles(1, cnt) = arPath(level - 1)
> arfiles(2, cnt) = level
>
> Set oFolder = FSO.GetFolder(sPath)
> Set oFiles = oFolder.Files
> For Each oFile In oFiles
> cnt = cnt + 1
> ReDim Preserve arfiles(2, cnt)
> arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
> arfiles(1, cnt) = oFile.Name
> arfiles(2, cnt) = level + 1
> Next oFile
>
> level = level + 1
> For Each oSubFolder In oFolder.Subfolders
> SelectFiles oSubFolder.Path
> Next
> level = level - 1
>
> End Sub
>
> #If VBA6 Then
> #Else
> '-----------------------------**-----------------------------*-*------
> Function Split(Text As String, _
> Optional Delimiter As String = ",") As Variant
> '-----------------------------**-----------------------------*-*------
> Dim i As Long
> Dim sFormula As String
> Dim aryEval
> Dim aryValues
>
> If Delimiter = vbNullChar Then
> Delimiter = Chr(7)
> Text = Replace(Text, vbNullChar, Delimiter)
> End If
>
> sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") &
> """}"
> aryEval = Evaluate(sFormula)
> ReDim aryValues(0 To UBound(aryEval) - 1)
> For i = 0 To UBound(aryValues)
> aryValues(i) = aryEval(i + 1)
> Next
>
> Split = aryValues
>
> End Function
>
> '---------------------------------------------------------------------------
> Public Function InStrRev(stringcheck As String, _
> ByVal stringmatch As String, _
> Optional ByVal start As Long = -1)
> '---------------------------------------------------------------------------
> Dim iStart As Long
> Dim iLen As Long
> Dim i As Long
>
> If iStart = -1 Then
> iStart = Len(stringcheck)
> Else
> iStart = start
> End If
>
> iLen = Len(stringmatch)
>
> For i = iStart To 1 Step -1
> If Mid(stringcheck, i, iLen) = stringmatch Then
> InStrRev = i
> Exit Function
> End If
> Next i
> InStrRev = 0
> End Function
> '-----------------------------------------------------------------
> #End If
>
>
> --
>
> HTH
>
> RP
> (remove nothere from the email address if mailing direct)
>
>
> "unni5959" <[email protected]> wrote in message
> news:[email protected]...
>> Hi
>> I found this cool macro on this group that makes a list of all files in
>> a folder. With each file name in a separate row. I would be very
>> grateful if any one can make suitable changes so that each row contains
>> a hyper link to the file.
>> TIA
>>
>> Unni
>>
>> Sub ListIndexFiles()
>> 'Lists all file names in the folder on the active sheet
>> Dim FileName As String
>> Dim r As Integer
>>
>> 'Range("a2:a5").ClearContents
>>
>> r = 2
>> With Application.FileSearch
>> .NewSearch
>> .LookIn = "C:\Documents and Settings\Administrator\My
>> Documents"
>> .FileName = "*.doc"
>> If .Execute() > 0 Then
>> For i = 1 To .FoundFiles.Count
>> FileName = Mid(.FoundFiles(i), 18)
>> Cells(r, 1) = FileName
>> r = r + 1
>> Next i
>> End If
>> End With
>> End Sub
>>
>
>

you didn't mention the grouping :-(

Bob


"Norman Jones" <[email protected]> wrote in message
news:[email protected]...
> Hi Bob,
>
> > Here is a different way, using FSO instead of the flaky FileSearch. It
> > also
> > searches down into sub-folders and indents the levels.
>
> Given the reported Filesearch problems and the indentation, its .....
"Slam
> Dunk!"
>
> ---
> Regards,
> Norman
>
>
>
> "Bob Phillips" <[email protected]> wrote in message
> news:[email protected]...
> > Here is a different way, using FSO instead of the flaky FileSearch. It
> > also
> > searches down into sub-folders and indents the levels.
> > Option Explicit
> >
> > Private cnt As Long
> > Private arfiles
> > Private level As Long
> >
> > Sub Folders()
> > Dim i As Long
> > Dim sFolder As String
> > Dim iStart As Long
> > Dim iEnd As Long
> > Dim fOutline As Boolean
> >
> > arfiles = Array()
> > cnt = -1
> > level = 1
> >
> > sFolder = "E:\"
> > ReDim arfiles(2, 0)
> > If sFolder <> "" Then
> > SelectFiles sFolder
> > Application.DisplayAlerts = False
> > On Error Resume Next
> > Worksheets("Files").Delete
> > On Error GoTo 0
> > Application.DisplayAlerts = True
> > Worksheets.Add.Name = "Files"
> > With ActiveSheet
> > For i = LBound(arfiles, 2) To UBound(arfiles, 2)
> > If arfiles(0, i) = "" Then
> > If fOutline Then
> > Rows(iStart + 1 & ":" & iEnd).Rows.Group
> > End If
> > With .Cells(i + 1, arfiles(2, i))
> > .Value = arfiles(1, i)
> > .Font.Bold = True
> > End With
> > iStart = i + 1
> > iEnd = iStart
> > fOutline = False
> > Else
> > .Hyperlinks.Add Anchor:=.Cells(i + 1, arfiles(2, i)),
_
> > Address:=arfiles(0, i), _
> > TextToDisplay:=arfiles(1, i)
> > iEnd = iEnd + 1
> > fOutline = True
> > End If
> > Next
> > .Columns("A:Z").ColumnWidth = 5
> > End With
> > End If
> > 'just in case there is another set to group
> > If fOutline Then
> > Rows(iStart + 1 & ":" & iEnd).Rows.Group
> > End If
> >
> > Columns("A:Z").ColumnWidth = 5
> > ActiveSheet.Outline.ShowLevels RowLevels:=1
> > ActiveWindow.DisplayGridlines = False
> >
> > End Sub
> >
> > '-----------------------------------------------------------------------
> > Sub SelectFiles(Optional sPath As String)
> > '-----------------------------------------------------------------------
> > Static FSO As Object
> > Dim oSubFolder As Object
> > Dim oFolder As Object
> > Dim oFile As Object
> > Dim oFiles As Object
> > Dim arPath
> >
> > If FSO Is Nothing Then
> > Set FSO = CreateObject("SCripting.FileSystemObject")
> > End If
> >
> > If sPath = "" Then
> > sPath = CurDir
> > End If
> >
> > arPath = Split(sPath, "\")
> > cnt = cnt + 1
> > ReDim Preserve arfiles(2, cnt)
> > arfiles(0, cnt) = ""
> > arfiles(1, cnt) = arPath(level - 1)
> > arfiles(2, cnt) = level
> >
> > Set oFolder = FSO.GetFolder(sPath)
> > Set oFiles = oFolder.Files
> > For Each oFile In oFiles
> > cnt = cnt + 1
> > ReDim Preserve arfiles(2, cnt)
> > arfiles(0, cnt) = oFolder.Path & "\" & oFile.Name
> > arfiles(1, cnt) = oFile.Name
> > arfiles(2, cnt) = level + 1
> > Next oFile
> >
> > level = level + 1
> > For Each oSubFolder In oFolder.Subfolders
> > SelectFiles oSubFolder.Path
> > Next
> > level = level - 1
> >
> > End Sub
> >
> > #If VBA6 Then
> > #Else
> > '-----------------------------**-----------------------------*-*------
> > Function Split(Text As String, _
> > Optional Delimiter As String = ",") As Variant
> > '-----------------------------**-----------------------------*-*------
> > Dim i As Long
> > Dim sFormula As String
> > Dim aryEval
> > Dim aryValues
> >
> > If Delimiter = vbNullChar Then
> > Delimiter = Chr(7)
> > Text = Replace(Text, vbNullChar, Delimiter)
> > End If
> >
> > sFormula = "{""" & Application.Substitute(Text, Delimiter, """,""") &
> > """}"
> > aryEval = Evaluate(sFormula)
> > ReDim aryValues(0 To UBound(aryEval) - 1)
> > For i = 0 To UBound(aryValues)
> > aryValues(i) = aryEval(i + 1)
> > Next
> >
> > Split = aryValues
> >
> > End Function
> >
> >
'---------------------------------------------------------------------------
> > Public Function InStrRev(stringcheck As String, _
> > ByVal stringmatch As String, _
> > Optional ByVal start As Long = -1)
> >
'---------------------------------------------------------------------------
> > Dim iStart As Long
> > Dim iLen As Long
> > Dim i As Long
> >
> > If iStart = -1 Then
> > iStart = Len(stringcheck)
> > Else
> > iStart = start
> > End If
> >
> > iLen = Len(stringmatch)
> >
> > For i = iStart To 1 Step -1
> > If Mid(stringcheck, i, iLen) = stringmatch Then
> > InStrRev = i
> > Exit Function
> > End If
> > Next i
> > InStrRev = 0
> > End Function
> > '-----------------------------------------------------------------
> > #End If
> >
> >
> > --
> >
> > HTH
> >
> > RP
> > (remove nothere from the email address if mailing direct)
> >
> >
> > "unni5959" <[email protected]> wrote in message
> > news:[email protected]...
> >> Hi
> >> I found this cool macro on this group that makes a list of all files in
> >> a folder. With each file name in a separate row. I would be very
> >> grateful if any one can make suitable changes so that each row contains
> >> a hyper link to the file.
> >> TIA
> >>
> >> Unni
> >>
> >> Sub ListIndexFiles()
> >> 'Lists all file names in the folder on the active sheet
> >> Dim FileName As String
> >> Dim r As Integer
> >>
> >> 'Range("a2:a5").ClearContents
> >>
> >> r = 2
> >> With Application.FileSearch
> >> .NewSearch
> >> .LookIn = "C:\Documents and Settings\Administrator\My
> >> Documents"
> >> .FileName = "*.doc"
> >> If .Execute() > 0 Then
> >> For i = 1 To .FoundFiles.Count
> >> FileName = Mid(.FoundFiles(i), 18)
> >> Cells(r, 1) = FileName
> >> r = r + 1
> >> Next i
> >> End If
> >> End With
> >> End Sub
> >>
> >
> >
>
>

Hi
Thank you Norman, Thank you Bob.

I am at loss of words!!

While Norman's macro fits what I was trying to do achieve perfectly,
Bob your code just blew mw away!! (Not just me... my whole department).
Poor ignoramus like us had no clue excel could do things like this. In
short you have just instilled in all of us a new respect for excel and
Excel newsgroup.

Thanks again

Unni

Hi Unni,

I am sure I can speak for Norman as well when I say thank you for those kind
words. I am sitting here with a big grin on my face.

Cheers

Bob


"unni5959" <[email protected]> wrote in message
news:[email protected]...
> Hi
> Thank you Norman, Thank you Bob.
>
> I am at loss of words!!
>
> While Norman's macro fits what I was trying to do achieve perfectly,
> Bob your code just blew mw away!! (Not just me... my whole department).
> Poor ignoramus like us had no clue excel could do things like this. In
> short you have just instilled in all of us a new respect for excel and
> Excel newsgroup.
>
> Thanks again
>
> Unni
>

Hi Bob/Norman,
Thanks a lot for the macro. I was also looking for one like this. It works great.

Can you please help me code anoher (may be seperately!) new macro which will delete the hyperlink as it is clicked by the user (while other hyperlinks remain in the sheet)?

Thanks a lot.

Twinkle

This will delete the hyperlink and clear the cell:

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Range(Target.Parent.Address).Value = ""
End Sub

or to delete the link but leave the hyperlink text in the cell:

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Target.delete
End Sub

This is worksheet event code. Right click the sheet, select View Code
and paste the code in there.

Hope this helps
Rowan

twinklejmj wrote:
> Hi Bob/Norman,
> Thanks a lot for the macro. I was also looking for one like this. It
> works great.
>
> Can you please help me code anoher (may be seperately!) new macro which
> will delete the hyperlink as it is clicked by the user (while other
> hyperlinks remain in the sheet)?
>
> Thanks a lot.
>
> Twinkle
>
>