PDA

View Full Version : getting worksheetnames as links



aoc
04-04-2007, 12:49 PM
hi,

below code helps to get worksheet names from different workbooks in different folders.At home it works well, but in the company it freezes some time later.folders are in the server, I can copy all of them to my computer then run the code below but my aim is to run the code without copying.
by getting the sheet names as links to one page, I will easily find and click the link.without that code I have to spend time to search the sheet.


Dim i As Integer 'Used in loop.
Dim wbResults As Workbook 'Name of workbook found
Dim wbCodeBook As Workbook 'Name of this workbook
Dim wSheet As Worksheet 'WorkSheet in found WorkBook
Dim mySearchPath As String 'Search Path
Dim mySearchPathLgth As Integer 'Length of path string used in Mid() function

Sub GetAllWorksheetNames()

On Error Resume Next

'Change the mySearchPath line to match the path
'where you want to search.
'Ensure the quotes (inverted commas) remain at each end.

mySearchPath = "D:\folder"

Sheets(1).Select

'Clear the sheet of all existing data
Cells.Select
Selection.Clear

'Insert column titles
Range("A1") = "Work Book Name"
Range("B1") = "Work Sheet Name"
Range("C1") = "Hyperlink"
Range("A1:C1").Font.Bold = True
Range("A1").Select

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

'Length of search path + 1 used to find next
'character in the mid()function used to find
'the worksheet name from the full path.
mySearchPathLgth = Len(mySearchPath) + 2

'Save Search Path for use in Hyperlinks.
'Can be saved anywhere but change the R1C27 in the
'Hyperlink code to match the row and column where saved.
'NOTE: R1C27 is Row 1 column 27 (same as cell AA1 but use
'R1C27 format in the hyperlink formula.
Sheets(1).Range("AA1") = mySearchPath & "\"

Set wbCodeBook = ThisWorkbook

With Application.FileSearch
.NewSearch
.LookIn = mySearchPath
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then ' 0 Then files of required type exist

For i = 1 To .FoundFiles.Count
Set wbResults = Workbooks.Open(.FoundFiles(i))
For Each wSheet In wbResults.Worksheets

'Write WorkBook Name to column 1
wbCodeBook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(2, 1) _
= Mid(.FoundFiles(i), mySearchPathLgth)

'Write the WorkSheet Name to column 2
wbCodeBook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(1, 2) _
= wSheet.Name

'Write Hyperlink to column 3
'Hyperlink code. If cell address where the path
'is saved has been changed then the first
'address (R1C27)must be changed to match.

'NOTE: the section of this code with the inverted commas
'(quotes) must be on one line. You cannot break this
'section of code with an underscore.
wbCodeBook.Sheets(1).Cells(Rows.Count, 1).End(xlUp)(1, 3).FormulaR1C1 = _
"=HYPERLINK(""[""&R1C27&RC[-2]&""]""&RC[-1]&""!A1"",""Open Sheet ""&RC[-1])"


Next wSheet
'Close the found workbook
wbResults.Close SaveChanges:=False
Next i
End If
End With

On Error GoTo 0

'Auto size columns for the data
Sheets(1).Select
Columns("A:C").Select
Selection.Columns.AutoFit

'Finalize
Range("A1").Select
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

mdmackillop
04-04-2007, 12:52 PM
Hi aoc,
When you post code, please select it and click the VBA button to format it as shown, making it more readable.

OBP
04-04-2007, 01:00 PM
aoc, see this thread by Ken puls
http://vbaexpress.com/forum/showthread.php?t=9283&highlight=browse

Post #15 for Browsing to a folder, rather than entering in the VB code.
It may handle the Server problem for you.

aoc
04-04-2007, 01:43 PM
hi,

I am a beginner, too difficult for me.

aoc
04-05-2007, 12:18 PM
u now the code ?