VBA To Create a Index Sheet of all VISIBLE sheets AND Populate with values from those sheets

[bhalbach]

I am trying to create an index sheet of all Visible sheets in a workbook, and also copy specific data from the sheets to the index sheet with VBA.

I have found some code that works great....Except it creates the Index sheet with ALL sheets in the workbook. I only want the sheets that are not hidden.

Also, while it is creating the Index sheet I would like it to copy data from each sheet to the Index sheet.

For Example if I have 20 visible sheets I would end up with a list of the sheet names on an index page...from these 20 sheets I would like to copy the data from cell's C5, I5 & J5 to the same row as the sheet name on the Index page.

The code I have now to make the index page is below, but it only copies ALL sheets to a Index sheet.

Please help...

Private Sub Worksheet_Activate()
'Updateby20150305
Dim xSheet As Worksheet
Dim xRow As Integer
Dim calcState As Long
Dim scrUpdateState As Long
Application.ScreenUpdating = False
xRow = 1
With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
End With
For Each xSheet In Application.Worksheets
If xSheet.Name <> Me.Name Then
xRow = xRow + 1
With xSheet
.Range("A1").Name = "Start_" & xSheet.Index
.Hyperlinks.Add anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
End With

 

[offthelip]

just add this if statement:

Private Sub Worksheet_Activate()
'Updateby20150305
Dim xSheet As Worksheet
Dim xRow As Integer
Dim calcState As Long
Dim scrUpdateState As Long
Application.ScreenUpdating = False
xRow = 1
With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
End With
For Each xSheet In Application.Worksheets
If xSheet.Name <> Me.Name Then
If xSheet.Visible Then          ''''''''''''''addthis line
xRow = xRow + 1
With xSheet
.Range("A1").Name = "Start_" & xSheet.Index
.Hyperlinks.Add anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
End With
End If
End If                  ' and this line
Next

End Sub

 

[bhalbach]

just add this if statement:

Private Sub Worksheet_Activate()
'Updateby20150305
Dim xSheet As Worksheet
Dim xRow As Integer
Dim calcState As Long
Dim scrUpdateState As Long
Application.ScreenUpdating = False
xRow = 1
With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
End With
For Each xSheet In Application.Worksheets
If xSheet.Name <> Me.Name Then
If xSheet.Visible Then          ''''''''''''''addthis line
xRow = xRow + 1
With xSheet
.Range("A1").Name = "Start_" & xSheet.Index
.Hyperlinks.Add anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
End With
End If
End If                  ' and this line
Next

End Sub

How would I then copy data from each visible sheet and past it to the index sheet as well at the same time as creating the Index sheet?

For Example if I have 20 visible sheets I would end up with a list of the sheet names on an index page (column A)...from these 20 sheets I would like to copy the data from cell's C5, I5 & J5 to the same row as the sheet name on the Index page. So C5 on sheet 1 would go to column B on the Index sheet, I5 would copy to column C on the Index, and J5 would copy to column D on the index sheet.

 

[offthelip]

try this:

Private Sub Worksheet_Activate()
'Updateby20150305
Dim xSheet As Worksheet
Dim xRow As Integer
Dim calcState As Long
Dim scrUpdateState As Long
Application.ScreenUpdating = False
Dim outarr() As Variant
nsht = Worksheets.Count
ReDim outarr(1 To nsht, 1 To 4)
xRow = 1
With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
End With
For Each xSheet In Application.Worksheets
If xSheet.Name <> Me.Name Then
If xSheet.Visible Then          ''''''''''''''addthis line
outarr(xRow, 1) = xSheet.Name
outarr(xRow, 2) = xSheet.Range("C5")
outarr(xRow, 3) = xSheet.Range("I5")
outarr(xRow, 4) = xSheet.Range("j5")
xRow = xRow + 1

With xSheet
.Range("A1").Name = "Start_" & xSheet.Index
.Hyperlinks.Add anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
End With
End If
End If                  ' and this line
Next
With Me
 .Range(Cells(2, 1), Cells(nsht + 1, 4)) = outarr
End With

End Sub

 

[bhalbach]

try this:

Private Sub Worksheet_Activate()
'Updateby20150305
Dim xSheet As Worksheet
Dim xRow As Integer
Dim calcState As Long
Dim scrUpdateState As Long
Application.ScreenUpdating = False
Dim outarr() As Variant
nsht = Worksheets.Count
ReDim outarr(1 To nsht, 1 To 4)
xRow = 1
With Me
.Columns(1).ClearContents
.Cells(1, 1) = "INDEX"
.Cells(1, 1).Name = "Index"
End With
For Each xSheet In Application.Worksheets
If xSheet.Name <> Me.Name Then
If xSheet.Visible Then          ''''''''''''''addthis line
outarr(xRow, 1) = xSheet.Name
outarr(xRow, 2) = xSheet.Range("C5")
outarr(xRow, 3) = xSheet.Range("I5")
outarr(xRow, 4) = xSheet.Range("j5")
xRow = xRow + 1

With xSheet
.Range("A1").Name = "Start_" & xSheet.Index
.Hyperlinks.Add anchor:=.Range("A1"), Address:="", _
SubAddress:="Index", TextToDisplay:="Back to Index"
End With
End If
End If                  ' and this line
Next
With Me
.Range(Cells(2, 1), Cells(nsht + 1, 4)) = outarr
End With

End Sub

Will not work....It doesnt like "nsht = Worksheets.Count

 

[offthelip]

Do you have option explicit at the top, if so try it without, or just declare everything that fails as type variant

 

[bhalbach]

Do you have option explicit at the top, if so try it without, or just declare everything that fails as type variant

Awesome thank you. I took out Option Explicit.

 

[bhalbach]

Do you have option explicit at the top, if so try it without, or just declare everything that fails as type variant

This works great.

How would I change this code to do the same thing, except start the paste of the data on the Index sheet starting on cell D5?

 

[bhalbach]

This works great.

How would I change this code to do the same thing, except start the paste of the data on the Index sheet starting on cell D5?

Instead of it starting on A1.

 

[offthelip]

change this line:

.Range(Cells(2, 1), Cells(nsht + 1, 4)) = outarr

to

.Range(Cells(5, 4), Cells(nsht + 4, 7)) = outarr