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
|