AW: Mehrere ASCII-Dateien automatisch abarbeiten
26.08.2009 12:52:47
fcs
Hallo Daniel,
da ist uns eine unterschiedlich Einstellungen für das Kopieren von Excel-Objekten zum Verhängnis geworden. Bei mir werden Objekte nicht zusammen mit den übergeordneten Zellen kopiert. Deshalb musste ich im Code das Diagramm nach dem Kopieren "hinterher kopieren".
Ich hab die Prozedur jetzt so angepasst, dass die Option ggf. vorübergehend auf True gesetzt wird, so dass das eingebettete Diagramm immer zusammen mit dem Muster-Tabellenblatt kopiert wird.
Gruß
Franz
'Erstellt mit Excel 2007, Windows Vista
'fcs - 2009-08-26
Sub MainProcedure()
'Variablen - Deklarationen
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet, wksMuster As Worksheet
Dim Pfad_ASC As String, Pfad_Diag As String, strASC_Datei As String
Dim objChart As Chart, Reihe As Series, objAxis As Axis
Dim ZeileStart As Long, ZeileEnde As Long, lngCount As Long
Dim bolObjectCopy As Boolean
'Kopieroption für Objekte setzen
bolObjectCopy = Application.CopyObjectsWithCells 'Objekt-Kopier-Option merken
If objectCopy = False Then Application.CopyObjectsWithCells = True
'Pfad der ASC-Dateien
Pfad_ASC = Worksheets("Steuerung").Range("D5")
'Pfad für erstellte Diagramm-Dateien
Pfad_Diag = Worksheets("Steuerung").Range("D7")
'Musterblatt in dieser Datei
Set wksMuster = ThisWorkbook.Worksheets("Muster")
'ASC-Dateien suchen
strASC_Datei = Dir(Pfad_ASC & "\*.ASC")
Application.ScreenUpdating = False
Do Until strASC_Datei = ""
lngCount = lngCount + 1
Application.StatusBar = "Diagramm wird erstellt aus: " & strASC_Datei _
& " Datei-Nr. " & lngCount
'ASC-Datei als Arbeitsmappe öffnen (Quelle)
Application.Workbooks.OpenText Filename:=Pfad_ASC & "\" & strASC_Datei, _
Origin:=xlWindows, startrow:=1, DataType:=xlDelimited, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, DecimalSeparator:=",", Local:=True
'Quellen-Objekte setzen
Set wbQuelle = ActiveWorkbook
Set wksQuelle = wbQuelle.Worksheets(1)
'Musterblatt in neue Arbeitsmappe kopieren (Ziel)
wksMuster.Copy
'Ziel-Objekte setzen
Set wbZiel = ActiveWorkbook
Set wksZiel = wbZiel.Worksheets(1)
'Blattname setzen = Blattname in ASC-DAtei
wksZiel.Name = wksQuelle.Name
With wksZiel
'Altdaten im Diagrammblatt weitestgehend löschen
.Range(.Cells(10, 1), Cells(.Rows.Count, 2).End(xlUp)).ClearContents
'Daten aus ASC-Datei kopieren und als Werte einfügen
With wksQuelle
.Range(.Columns(1), .Columns(2)).Copy
End With
.Cells(1, 1).PasteSpecial Paste:=xlValues
'ASC-Quelldatei wieder schliessen - Alarmmeldungen deaktivieren wegen _
großer Datenmenge in Zwischenablage
Application.DisplayAlerts = False
wbQuelle.Close savechanges:=False
Application.DisplayAlerts = True
'der Datenreihe die kopierten Werte zuweisen
Set objChart = .ChartObjects(1).Chart
ZeileStart = 8 '1. Zeile mit Diagrammdaten
ZeileEnde = .Cells(.Rows.Count, 1).End(xlUp).Row 'Letzte Zeile mit Diagrammdaten
Set Reihe = objChart.SeriesCollection(1)
Reihe.XValues = .Range(.Cells(ZeileStart, 1), .Cells(ZeileEnde, 1))
Reihe.Values = .Range(.Cells(ZeileStart, 2), .Cells(ZeileEnde, 2))
'Kategorienachse skalieren (Min- und Max-Wert)
Set objAxis = objChart.Axes(Type:=xlCategory)
With objAxis
.MinimumScale = Int(wksZiel.Cells(ZeileStart, 1))
.MaximumScale = VBA.Round(wksZiel.Cells(ZeileEnde, 1) + 0.49, 0)
End With
End With
'Erstellte Diagramm-Datei speichern im Excel 2007-Format und schliessen
wbZiel.SaveAs Filename:=Pfad_Diag & "\" & wksZiel.Name & ".xlsx", _
FileFormat:=xlWorkbookDefault, addtoMRU:=False
wbZiel.Close
'nächste ASC-Datei zuweisen
strASC_Datei = Dir
Loop
'Kopieroption für Objekte zurücksetzen
If bolObjectCopy = False Then Application.CopyObjectsWithCells = False
Application.StatusBar = False
Application.ScreenUpdating = True
End Sub