Readdy Write  
0,00 €
Your View Money
Views: Count
Self 20% 0
Your Content 60% 0

Users by Links 0
u1*(Content+Views) 10% 0
Follow-Follower 0
s2*(Income) 5% 0

Count
Followers 0
Login Register as User

Excel: Daten-Blätter und System Blätter ausblenden

23.12.2018 (👁6236)

Excel: Daten-Blätter und System Blätter ausblenden

 

 

Der folgende vba Makro Code zeigt, wie man in Excel automatisch Bereiche wie Datenblätter, Zwischenberechnungen und #Setup Blätter ausblenden und wieder einblenden kann.

Durch die Verwendung von Excel vba Makro-code kann somit die Verwaltung von Excel als Datenaustausch in kleinen Gruppen optimiert werden.

 

Betrifft: vba Makro Code

 

Die Datei ist zum Download im Anhang

 

Durch Ausblenden und Einblenden der gelben Zwischen-Berechnungen und einiger Datenblätter, die nur fßr die Anreicherung von Daten gedacht sind.

 

Ausblenden

Durch Klick auf den Ausblenden Button wird der Daten-Quellen Bereich und die System-Excelblätter mit # ausgeblendet

 

Einblenden

Und durch den Einblenden Code wird der Entwicklungsbereich wieder in Excel eingeblendet

 

 

Vba Makro Code

Option Explicit On

 

 

Public Sub Verknuepfung_Linked_Shapes_zu_Excel_aendern()

    '--------------------< Verknuepfung_Linked_Shapes_zu_Excel_aendern() >---------------- 

    '*mit diesem Makro werden alle verlinkten Graphiken zu Excel-Dokumenten zu einem neuen Pfad erneuert 

    '< setup > 

    Dim sPfad As String

    sPfad = "C:\Users\poppr\Desktop\Excel_Datei.xlsm"

    '</ setup > 

 

    '< meldung > 

    If vbYes <> MsgBox("Das Anbinden kann länger dauern.. " & vbCrLf & "Das Makro oeffnet gleich die ZielExcel-Datei und bindet die Folien an." & vbCrLf & "Soll gestartet werden ..", vbYesNo, "Soll die Anbindung gestartet werden?"Then

        Exit Sub

    End If

    '</ meldung > 

 

    '< Excel_oeffnen > 

    '*erst Excel Ziel oeffnen 

    Dim objExcel As Excel.Application

    Set objExcel = New Excel.Application 

    objExcel.Workbooks.Open sPfad 

    '</ Excel_oeffnen > 

 

    '< init > 

    Dim objPPT As Presentation

    Set objPPT = ActivePresentation 

    '</ init > 

    

    '--------< @Loop:Slides >-------- 

    Dim objSlide As Slide

    For Each objSlide In objPPT.Slides

        '------< Slide >------ 

        '------< @Loop: Shapes >------ 

        Dim objShape As Shape

        For Each objShape In objSlide.Shapes

            '------< Shape >------ 

            DoEvents    '* 

 

            If objShape.Type = msoLinkedOLEObject Then

                '----< IsLinkedOLEObject >---- 

                '< set_Link_manual > 

                '*zur Sicherheit Link auf Manuell schalten 

                'manuelle Verknuepfung 

                If Not objShape.LinkFormat.AutoUpdate = ppUpdateOptionManual Then

                    objShape.LinkFormat.AutoUpdate = ppUpdateOptionManual

                End If

                '</ set_Link_manual > 

 

                '----< Check_Link_IsExcel >---- 

                '*wie: Excel.SheetMacroEnabled.12 

                If InStr(objShape.OLEFormat.ProgID, "Excel.Sheet") > 0 Then

                    '--< Link_IsExcel >-- 

                    Dim sLink As String

                    sLink = objShape.LinkFormat.SourceFullName

                    '*Link ist wie:   C:\.....xxx.xlsm!ExcelBlatt!Z1S1:Z1:S1 

 

                    If InStr(1, sLink, sPfad, vbTextCompare) < 1 Then

                        '----< Link_ist_falsch >---- 

 

                        '< get pos_Excel > 

                        Dim pos_Excel As Integer

                        pos_Excel = InStrRev(sLink, ".xls", -1, vbTextCompare)

                        '</ get pos_Excel > 

 

                        If pos_Excel > 0 Then

                            '< get_pos_Area > 

                            Dim posArea As Integer

                            posArea = InStr(pos_Excel, sLink, "!", vbBinaryCompare)

                            '<( get_pos_Area > 

 

                            '< get neuer Pfad > 

                            Dim sArea As String

                            sArea = Mid(sLink, posArea)

 

                            Dim sLink_Neu As String

                            sLink_Neu = sPfad & sArea

                            '</ get neuer Pfad > 

 

                            '< Link aendern > 

                            objShape.LinkFormat.SourceFullName = sLink_Neu

                            '< Link aendern > 

                        End If

                        '----</ Link_ist_falsch >---- 

                    End If

                    '--</ Link_IsExcel >-- 

                End If

                '----</ Check_Link_IsExcel >---- 

                '----</ IsLinkedOLEObject >---- 

            End If

            '------</ Shape >------ 

        Next

        '------</ @Loop: Shapes >------ 

        '------</ Slide >------ 

    Next

    '--------</ @Loop:Slides >-------- 

 

    '< Abschluss > 

    objExcel.Quit

    '</ Abschluss > 

 

    MsgBox("Fertig!")

    '--------------------</ Verknuepfung_Linked_Shapes_zu_Excel_aendern() >---------------- 

End Sub