Office: (Office 2010) xlSheetType bei Erstellen von Diagrammen per VBA

Hallo,

ich möchte mehrere Sheets aus einem Arbeitsblatt in ein neues kopieren. Dieses wird dann gespeichert und geschlossen - zur Archivierung. Die mitkopierten Diagramme (per VBA erstellt) behalten aber ihre Hyperlinks, was ich unterbinden möchte.

Deshalb dachte ich mir, ich unterscheide beim kopieren zwischen xlChart und xlWorksheet, allerdings sind die Diagramme als xlExcel4IntlMacroSheet definiert. Und für diesen SheetType funktioniert die Methode CopyPicture leider nicht, was das Problem mit den Hyperlinks lösen könnte.

Nun habe ich mir verschiedene Ansätze überlegt:

- Die Diagramm als xlChart definieren (Weiß nicht wie das geht)
- Die neue Datei so definieren, dass Verknüpfung nicht aktiviert werden können (weiß ich auch nicht wie das geht)
- Eine andere Variante für das Kopieren von Diagrammen ohne Hyperlinks wäre die andere (hab keine Idee dazu)

Falls jemand weiß, wie das gehen könnte, wäre ich sehr dankbar.

Gruß Ice


Edit: Selbst mit Hand erstellte Diagramme werden nicht als Typ xlChart definiert.

Edit2: Habe mir mittlerweile eine andere Möglichkeit überlegt und zwar mit SaveAs, allerdings ist hier dann die Makro-Datei nicht mehr geöffnet, sondern die Kopie davon.

Edit3: Habe nun das ganze umgegangen, in dem ich die Makrodatei speichere, dann als Kopie speichere (als .xlsx), dann das Orignal wieder öffne und die Kopie schließe.

Nicht schön, aber es funktioniert. Falls jemand eine schönere Lösung hat (und die Zeit dafür) wäre ich trotzdem noch dankbar!

 

Hi,

was verstehst du unter "die Diagramme behalten ihre Hyperlinks"? In Diagrammen gibt es keine Hyperlinks, höchsten Zellbezüge zum Wertebereich.
Wie kopierst du die Tabellenblätter?

Bis später,
Karin

 

Hey,
ja ich meine tatsaächlich die Zellbezüge. Ich habe die Tabellenblätter mit:

For Each obj In Application.Sheets
If obj.Name <> "Makro" Then
If obj.Type = xlChart Then
WbkQ.Sheets(lngs).CopyPicture _
After:=WbkZ.Sheets(lngAnzahl)
lngs = lngs + 1
lngAnzahl = lngAnzahl + 1
Else
WbkQ.Sheets(lngs).Copy _
After:=WbkZ.Sheets(lngAnzahl)
lngs = lngs + 1
lngAnzahl = lngAnzahl + 1
End If
End If
Next obj

kopiert.

 

Hi,

nur mal zur Klarstellung: ein Sheet kann sowohl ein Arbeitsblatt (bzw. auch Tabelle oder Tabellenblatt genannt) als auch ein Diagrammblatt sein und beide Typen befinden sich in einem Workbook (Arbeitsmappe). Man sollte schon die Bezeichungen korrekt verwenden, weil dies sonst zu Missverständnissen führen kann.

Wenn ich das richtig sehe, sollen alle Arbeitsblätter außer das mit dem Namen "Makro" und alle Diagrammblätter in die neue Arbeitsmappe kopiert werden?

Code:

Sub SheetsKopieren()
    Dim lngTabs As Long
    Dim lngZaehler As Long
    lngZaehler = 1
    Dim arrTabellen()
    ReDim arrTabellen(1 To Sheets.Count - 1)
    For lngTabs = 1 To Sheets.Count
        If Sheets(lngTabs).Name <> "Makro" Then
            arrTabellen(lngZaehler) = lngTabs
            lngZaehler = lngZaehler + 1
        End If
    Next lngTabs
    Sheets(arrTabellen).Copy
End Sub

Bis später,
Karin

 

Hi,

danke schonmal für die Hilfe,

soweit ich das sehe, habe ich Bezeichnungen korrekt verwendet (bis auf Hyperlink (Excel nennt es auch Verknüpfung).

Ziel ist es, bei dem Kopiervorgang die Diagramme ohne Zellbezug zu kopieren. Bzw. den Zellbezug automatisch zu ändern, da ich das Tabellenblatt mit den Daten mitkopiere.

Hier mal mein gesamter Code mit allen Varianten, die ich bisher ausprobiert habe. Auch mit Save As löse ich mein Problem nicht, der Zellbezug besteht weiterhin zur original Datei

Code:

Private Sub CommandButton3_Click()

'***    Auswertung exportieren
Dim strZiel As String, strQuel As String
Dim strAnfang As String, strEnde As String, strPfad As String, strName As String
Dim WbkZ As Workbook, WbkQ As Workbook
Dim lngAnzahl As Long, lngs As Long
Dim strs As String, strName2 As String
Dim obj As Object

'***    Quell-Arbeitsblatt festlegen
Set WbkQ = ThisWorkbook

'***    Kontrolle, ob Auswertung vorhanden ist
If WbkQ.Sheets.Count > "1" Then

Else
MsgBox "Keine Auswertung vorhanden!", vbCritical
Exit Sub
End If

'***    Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'***    Zeitbereich für Namensgebung auslesen
lngAnzahl = WbkQ.Worksheets(2).UsedRange.Rows.Count
strAnfang = Format(Sheets(2).Cells(2, 7), "DD_MM_YY")
strEnde = Format(Sheets(2).Cells(lngAnzahl, 7), "DD_MM_YY")
strName2 = WbkQ.Name
strPfad = ActiveWorkbook.Path
strName = strPfad & "\Auswertung Stahl E-Trak  " & strAnfang & " bis " & strEnde & ".xlsx"
'Set WbkZ = Workbooks.Add(1)
WbkQ.Save
WbkQ.Worksheets(1).Delete
WbkQ.SaveAs strName, FileFormat:=xlOpenXMLWorkbook

'Set WbkZ = strPfad & strName2
Workbooks.Open "E-Trak - Auswertungsmakro2.xlsm"
WbkQ.Close

'WbkQ.Activate
'lngs = 2
'lngAnzahl = WbkZ.Sheets.Count

'
'For Each obj In Application.Sheets
'    If obj.Name <> "Makro" Then
'        If obj.Type = xlWorksheet Then
'            WbkQ.Sheets(lngs).Copy _
'            After:=WbkZ.Sheets(lngAnzahl)
'            lngs = lngs + 1
'            lngAnzahl = lngAnzahl + 1
'        Else
'            WbkQ.Sheets(lngs).Copy _
'            'WbkZ.Sheets(lngAnzahl).PastePicture
'            WbkZ.Sheets.Add After:=WbkZ.Sheets(lngAnzahl - 1)
'            WbkZ.Sheets(lngAnzahl).Paste (xlPasteValues)
'            lngs = lngs + 1
'            lngAnzahl = lngAnzahl + 1
'        End If
'    End If
'Next obj




''***    Arbeitblätter in die neu erstellte Arbeitsmappe kopieren
'For Each obj In Application.Sheets
'    If obj.Name <> "Makro" Then
'        If obj.Type = xlChart Then
'            WbkQ.Sheets(lngs).CopyPicture _
'            After:=WbkZ.Sheets(lngAnzahl)
'            lngs = lngs + 1
'            lngAnzahl = lngAnzahl + 1
'        Else
'            WbkQ.Sheets(lngs).Copy _
'            After:=WbkZ.Sheets(lngAnzahl)
'            lngs = lngs + 1
'            lngAnzahl = lngAnzahl + 1
'        End If
'    End If
'Next obj

'Dim iCount As Integer
'Dim iType As Integer
'Dim sTemp As String
'Dim oChart As Chart
'Dim bFound As Boolean
'
'WbkQ.Activate
'lngs = 2
'lngAnzahl = WbkZ.Sheets.Count
'For Each obj In Application.Sheets
'    WbkQ.Activate
'    If obj.Name <> "Makro" Then
'        iType = Sheets(lngs).Type
'        bFound = False
'        For Each oChart In Charts
'            If oChart.Name = Sheets(lngs).Name Then
'                bFound = True
'            End If
'        Next oChart
'        If bFound = True Then
'            WbkQ.Sheets(lngs).CopyPicture _
'            After:=WbkZ.Sheets(lngAnzahl)
'            lngs = lngs + 1
'            lngAnzahl = lngAnzahl + 1
'        Else
'            WbkQ.Sheets(lngs).Copy _
'            After:=WbkZ.Sheets(lngAnzahl)
'            lngs = lngs + 1
'            lngAnzahl = lngAnzahl + 1
'        End If
'    End If
'Next obj



'***    Zieldatei speichern und schließen
'WbkQ.Close savechanges:=True

'***    Bildschirmaktualisierung wieder einschalten
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "Die Datei " & strName & " wurde erfolgreich exportiert.", vbExclamation
    
End Sub

Edit: Hab deinen Code mal ausprobiert und er funktioniert einwandfrei, was der ist der Unterschied bei deinem Kopiervorgang zu meinen Kopier- bzw SaveAs-Vorgängen?
Ist der entscheidene Unterschied, dass ich ganze Sheets kopiere und du diese in ein Array packst?


Edit2: so sieht dann dein Code in mein Programm eingebunden aus, funktioniert alles super, vielen Dank!

Code:

Private Sub CommandButton3_Click()

'***    Auswertung exportieren
Dim strAnfang As String, strEnde As String, strPfad As String, strName As String
Dim WbkQ As Workbook
Dim lngAnzahl As Long
Dim lngTabs As Long
Dim lngZaehler As Long

'***    Quell-Arbeitsblatt festlegen
Set WbkQ = ThisWorkbook

'***    Kontrolle, ob Auswertung vorhanden ist
If WbkQ.Sheets.Count > "1" Then

Else
MsgBox "Keine Auswertung vorhanden!", vbCritical
Exit Sub
End If

'***    Bildschirmaktualisierung ausschalten
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'***    Zeitbereich für Namensgebung auslesen
lngAnzahl = WbkQ.Worksheets(2).UsedRange.Rows.Count
strAnfang = Format(Sheets(2).Cells(2, 7), "DD_MM_YY")
strEnde = Format(Sheets(2).Cells(lngAnzahl, 7), "DD_MM_YY")
strPfad = ActiveWorkbook.Path
strName = strPfad & "\Auswertung Stahl E-Trak  " & strAnfang & " bis " & strEnde & ".xlsx"

lngZaehler = 1
Dim arrTabellen()
ReDim arrTabellen(1 To Sheets.Count - 1)
For lngTabs = 1 To Sheets.Count
    If Sheets(lngTabs).Name <> "Makro" Then
        arrTabellen(lngZaehler) = lngTabs
        lngZaehler = lngZaehler + 1
    End If
Next lngTabs
Sheets(arrTabellen).Copy

'***    Zieldatei speichern und schließen
ActiveWorkbook.Close savechanges = True, Filename = strName

'***    Bildschirmaktualisierung wieder einschalten
Application.ScreenUpdating = True
Application.DisplayAlerts = True

MsgBox "Die Datei " & strName & " wurde erfolgreich exportiert.", vbExclamation
    
End Sub

 

Hi,

mit meinem Code werden durch die Benutzung des Arrays die Arbeitsblätter, auf die sich die Diagramme beziehen, zusammen mit den Diagrammblättern als neue Arbeitsmappe erstellt und nicht einfach in eine neue (andere) Arbeitsmappe kopiert - das ist der Unterschied zu deinem Code. Dadurch bleibt der Bezug in den Diagrammen auf die neu erstellt Arbeitsmappe.

Falls du mal Diagramme in eine andere Arbeitsmappe kopieren und ihre Bezüge auf die neue Mappe ändern willst, musst du einfach in einer Schleife über alle Diagramme und dort wiederum über alle Datenreihen laufen und in deren Datenreihenformel den Bezug zur Ausgangsarbeitsmappe löschen (einfach durch Nichts ersetzen).

Bis später,
Karin

 

Eine letzte Sache noch: Ich dachte das passiert auch, wenn man die Datei unter einem anderen Namen abspeichert. War ein bisschen irritiert, als das nicht funktioniert hat.

Vielen Dank nochmal für die Hilfe!

 

Wenn du die Original-Arbeitsmappe mit den Diagrammen unter einem anderen Namen speicherst, dann sind die Diagrammbezüge selbstverständlich auf die neue Arbeitsmappe und nicht auf die Ausgangsmappe.

Es gibt übrigens 2 Möglichkeiten zum Speichern: SaveAs (Speichern als) und SaveCopyAs (Kopie speichern als) - bei SaveAs wird die Originalmappe unter dem neuen Namen gespeichert (und die Ausgangsmappe "ist weg"), bei SaveCopyAs wird eine Kopie der Originalmappe unter dem neuen Namen gespeichert (und die Ausgangsmappe "bleibt da").

Bis später,
Karin