Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel

Сообщение успешно добавлено.

Страницы: 1
RSS
Скрыть листы в Excel так, чтобы они отображались, когда переходишь к ним по гиперссылке SHAPE
 
#1
28.12.2021 10:39:03
Здравствуйте!
Уважаемые форумчане, помогите, пожалуйста, со следующим вопросом.
Есть файл с несколькими листами. На главной странице сделаны гиперссылки на каждый лист. Гиперссылки прописаны в объектах рисования (автофигуры). На каждом листе есть гиперссылка на главную страницу.    
Хотелось бы перемещаться по листам только по гиперссылкам, а все листы, кроме активного, были бы скрыты.
Очень похожая тема здесь: https://www.planetaexcel.ru/forum/index.php?PAGE_NAME=read&FID=8&TID=29560
Но там нет автофигур (Shape)
Результат темы выше:
Код
Private Sub Workbook_SheetFollowHyperlink(ByVal sh As Object, ByVal Target As Hyperlink)  
If Target.Address <> "" Then Exit Sub 'внешняя гиперссылка  
Range(Target.SubAddress).Parent.Visible = xlSheetVisible: sh.Visible = xlSheetHidden  
End Sub
 
 
 
#2
28.12.2021 11:09:32
Вариант через макросы.
Код
Sub forShape1()
    forShapeI "Лист1"
End Sub

Sub forShape2()
    forShapeI "Лист2"
End Sub

'...

Sub forShapeI(sheetName As String)
    With Sheets(sheetName)
        .Visible = True
        ActiveSheet.Visible = False
        .Activate
    End With
End Sub
 
 
 
#3
28.12.2021 11:23:34
Здравствуйте, МатросНаЗебре!
Спасибо за отзыв, но не понимаю, как Ваш код добавить к коду первого поста
Помогите, пожалуйста
 
 
 
#4
28.12.2021 11:47:47
Надо вставить в стандартный модуль.
В редакторе VBE (Alt+F11) правый клик мышки на модуле, например, "ЭтаКнига"
Insert - Module
Вставить текст с форума в появившееся окно.
Переключаетесь на лист с автофигурами.
Правый клик мышкой на фигуре, которая должна перевести на "Лист1".
Назначаете макрос forShape1.
И так далее для всех автофигур.
 
 
 
#5
28.12.2021 12:05:01
МатросНаЗебре, подскажите, а нет ли более короткого пути? Дело в том, что в оригинальном файле на листе с автофигурами более 100 автофигур с ссылками.
 
 
 
#6
28.12.2021 12:55:38
Есть более короткий путь. Не факт, что более простой )
Код
Option Explicit

Sub FillMacroLinksinActiveWorkbook()
    Dim objVBComp As Object
    Set objVBComp = GetLinkModule()
    'получаем ссылку на коды модуля
    Dim objCodeMod  As Object
    Set objCodeMod = objVBComp.CodeModule
    
    Dim lLineNum As Long
    
    Dim hl As Hyperlink
    Dim macroName As String
    Dim sheetName As String
    Dim sProcLines As String
    Dim sh As Worksheet
    Dim i As Long
    For Each sh In ActiveWorkbook.Worksheets
        sh.Visible = xlSheetVisible
        For Each hl In sh.Hyperlinks
            'Debug.Print hl.Shape.OnAction
            On Error Resume Next
            i = i + 1
            macroName = "Macro" & Replace(hl.Shape.Name, " ", "") & "_" & i
            hl.Shape.OnAction = macroName
            sheetName = Split(hl.SubAddress, "!")(0)
            
            sProcLines = "Sub " & macroName & "()" & vbCrLf & _
            "    forShapeI """ & sheetName & """" & vbCrLf & _
            "End Sub" & vbCrLf
            
            lLineNum = objCodeMod.CountOfLines + 1
            'Stop
            objCodeMod.InsertLines lLineNum, sProcLines
            If Err = 0 Then hl.Delete
            On Error GoTo 0
        Next
    Next
End Sub

Function GetLinkModule() As Object
    Dim objVBProj As Object, objVBComp As Object, objCodeMod As Object
    Dim sModuleName As String, sFullName As String
    Dim sProcLines As String
    Dim lLineNum As Long
 
    'добавляем новый стандартный модуль в активную книгу
    On Error Resume Next
    Set objVBComp = ActiveWorkbook.VBProject.VBComponents("LinkModule")
    On Error GoTo 0
    
    If objVBComp Is Nothing Then
        Set objVBComp = ActiveWorkbook.VBProject.VBComponents.Add(1)
        objVBComp.Name = "LinkModule"
    
    
        'получаем ссылку на коды модуля
        Set objCodeMod = objVBComp.CodeModule
        'узнаем количество строк в модуле
        '(т.к. VBA в зависимости от настроек может добавлять строки деклараций)
        lLineNum = objCodeMod.CountOfLines + 1
        'текст всставляемой процедуры
        sProcLines = vbCrLf & "Sub forShapeI(sheetName As String)" & vbCrLf & _
            "    With Sheets(sheetName)" & vbCrLf & _
            "        .Visible = True" & vbCrLf & _
            "        ActiveSheet.Visible = False" & vbCrLf & _
            "        .Activate" & vbCrLf & _
            "    End With" & vbCrLf & _
            "End Sub" & vbCrLf
        'вставляем текст процедуры в тело нового модуля
        objCodeMod.InsertLines lLineNum, sProcLines
        
    End If
    Set GetLinkModule = objVBComp
    
    
End Function
 
 
 
#7
28.12.2021 14:37:42
МатросНаЗебре, огромное спасибо!
 
 
 
Страницы: 1

Сообщение успешно добавлено.

Наверх