Microsoft Excel:

  Таблицы и VBA. Справочник.
  Вопросы и Ответы. Советы. Примеры.
Меню Заметки | Как создать перечень имён листов и связи с ними


Rambler's Top100


Counter CO.KZ

Первоначально оригинал этого кода был опубликован в далёком 2004г. и являлся пробой пера в Excel. Правда, вполне прилично справлялся со своей задачей, хоть и выглядел не особо читаемо. Множество пустых строк, отсутствие форматирования(отступов и т.д.), наличие (на выбор) сразу двух вариантов определения индекса листа (он же и номер строки) и т.п. В общем, те, кто интересуется археологией и не имеют сердечно-сосудистых заболеваний, могут увидеть оригинал в Архиве интернета. Другие же, смогут воспользоваться более читабельной версией, которая появилась спустя год, в архиве же, она была сохранена, почему-то, только в 2006г. В любом случае, далее приводится оригинал, без купюр и цензуры :)
Private Sub ИменаЛистов()

'*******************************************************
' ИменаЛистов
' Макрос записан очень давно ' изменен ../../2005
' Автор Климов Павел Юрьевич

' http://www.msoffice.nm.ru
'*******************************************************

For Each iList In ActiveWorkbook.Worksheets
    With Worksheets(1).Cells(iList.Index, 1)
         .Hyperlinks.Add Anchor:=.Item(1), Address:="", SubAddress:="'" & iList.Name & "'" & "!A1"
         .Formula = iList.Name
    End With
Next

End Sub
Только имейте ввиду, что количество рабочих листов не есть константа и при следующем запуске их может стать меньше. Поэтому, имеет смысл предварительно удалять все гиперссылки в указанном столбце. Иначе есть риск, что останется мусор от прежних данных.
Worksheets(1).Columns(1).Hyperlinks.Delete
Или же, вообще, очищать ячейки столбца A, например, если мы в макросе раскрасим ячейки в цвет соответствующих ярлычков, см. далее.

Кроме того, если листов много, но можно протестировать вариант, где на время создания списка(перечня) мы блокируем обновление экрана, т.е.
Private Sub NameList3()
    '*******************************************************
    ' ИменаЛистов
    ' Макрос записан очень давно ' изменен ../../2005/2020
    ' Автор Климов Павел Юрьевич

    ' http://www.msoffice-nm.ru (http://www.msoffice.nm.ru)
    '*******************************************************

    Application.ScreenUpdating = False
    Worksheets(1).Columns(1).Clear
    Dim iList As Worksheet
    For Each iList In Worksheets
        With Worksheets(1).Cells(iList.Index, 1)
             .Hyperlinks.Add Anchor:=.Item(1), Address:="", SubAddress:="'" & iList.Name & "'" & "!A1"
             .Formula = iList.Name
             .Interior.ColorIndex = iList.Tab.ColorIndex
        End With
    Next
    Application.ScreenUpdating = True
End Sub
Private Sub NameList3v2()
    '*******************************************************
    ' ИменаЛистов
    ' Макрос записан очень давно ' изменен ../../2005/2020
    ' Автор Климов Павел Юрьевич

    ' http://www.msoffice-nm.ru (http://www.msoffice.nm.ru)
    '*******************************************************

    Application.ScreenUpdating = False: Worksheets(1).Columns(1).Clear
    Dim iList As Worksheet
    For Each iList In Worksheets
        With Worksheets(1).Cells(iList.Index, 1)
             .Hyperlinks.Add .Item(1), "", iList.[A1].Address(, , , True)
             .Formula = iList.Name
             .Interior.ColorIndex = iList.Tab.ColorIndex
        End With
    Next
    Application.ScreenUpdating = True
End Sub
А если и этого мало, то нижеопубликованный макрос, сможет создать скриншоты каждого рабочего листа и связать их с этими листами. Рюшечки и бантики, как-то тень, не являются обязательным элементом данного макроса и могут быть искорены самым злодейским способом :)

Обратите внимание на то, что скриншот создаётся не всего рабочего листа целиком, а только его части, точнее сказать трёх строк и десяти столбцов. Разумеется, и это не является обязательным условием, и количество ячеек можно указать другое.
Private Sub ScreenList()
    Dim iList As Worksheet, iSource As Range, iCount&, iTop!: iTop = 10
    Set iList = Worksheets(1): iList.DrawingObjects.Delete
    For iCount = 2 To Worksheets.Count
        Set iSource = Worksheets(iCount).UsedRange.Cells(1, 1).Resize(3, 10)
        iSource.CopyPicture xlScreen, xlBitmap
        With iList.Pictures.Paste
             .Left = 10: .Top = iTop: iTop = iTop + iSource.Height + 20
             .ShapeRange.Shadow.Type = msoShadow6
             iList.Hyperlinks.Add .ShapeRange(1), "", iSource.Address(External:=True), iList.Name
        End With
    Next
End Sub
A если воспользуетесь вторым вариантом, то получите не статический скриншот, а фото(камеру), которая будет изменяться синхронно вместе с исходным данными, форматами и даже графикой исходного диапазона.
Private Sub ScreenList2()
    Application.ScreenUpdating = False
    Dim iList As Worksheet, iSource As Range, iCount&, iTop!: iTop = 10
    Set iList = Worksheets(1): iList.DrawingObjects.Delete
    For iCount = 2 To Worksheets.Count
        Set iSource = Worksheets(iCount).UsedRange.Cells(1, 1).Resize(3, 10)
        iSource.CopyPicture xlScreen, xlPicture
        With iList.Pictures.Paste
             .Left = 10: .Top = iTop: iTop = iTop + iSource.Height + 10
             .Formula = iSource.Address(External:=True)
             .ShapeRange.Fill.Visible = msoTrue
             .ShapeRange.Shadow.Type = msoShadow6
             iList.Hyperlinks.Add .ShapeRange(1), "", .Formula, iList.Name
        End With
    Next
    Application.ScreenUpdating = True
End Sub
Важно : В качестве места размещения скриншотов, выступает самый первый рабочий лист и он не участвует в переборе листов.


Автор : Климов Павел Юрьевич
© 2004-2020 Климов П.Ю. Все права защищены. WebDesign & Error's Klimoff