Clean Memory
30.01.2014 16:25:32
Fabio
Ich habe eine Makro erzeugt, die folgendes macht:
- über einen Knopf kann man Dateien auswählen, die man bearbeiten möchten. Es wird in Excel eine Liste erzeugt;
- über einen 2. Knopf werden die Dateien in der Liste über den Excel-Import eingelesen (es handelt sich um Messdaten) und ein neues Worksheet pro Datei wird kreiert;
- danach werden die Messdaten ausgedünnt und pro neues Worksheet wird ein Diagramm erzeugt.
Das Problem ist, dass nach etwa 30 Dateien, eine Fehlermeldung kommt. Wenn ich Excel zu mache und ab der abgestürzten Datei fortsetze, läuft die Makro weiter für etwa 30 Dateien. Ich vermute, es ist ein Problem mit der RAM, die langsam voll belegt wird.
Gibt es eine Möglichkeit, die RAM zu befreien?
Hier der Code dazu:
Subroutine 1:
Option Explicit
Sub Jet_Importieren()
Dim n, k, l As Integer
Dim Dateipfad, Dateiname, Tabellenname As String
Dim Worksheetname, xlsDateipfad As String
Worksheetname = ActiveWorkbook.Name
n = 0
Do Until IsEmpty(Range("A5").Offset(n, 0))
Dateipfad = Range("A5").Offset(n, 0)
k = InStr(1, Dateipfad, "test") ' Hier muss der Names des Jets-Projekts als letzer _
Ausdruck stehen
l = Len(Dateipfad)
k = l - k
k = k + 1
Dateiname = Right(Dateipfad, k)
l = Len(Dateiname)
k = l - 4
Tabellenname = Left(Dateiname, k)
Workbooks.Add
If FileLen(Dateipfad) 0 Then
With ActiveSheet.QueryTables.Add(Connection:= _
"TEXT;" & Dateipfad, _
Destination:=Range("$A$1"))
.Name = "Dateiname"
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.TextFilePromptOnRefresh = False
.TextFilePlatform = 850
.TextFileStartRow = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
ActiveSheet.Name = Tabellenname
xlsDateipfad = Replace(Dateipfad, ".csv", ".xls")
ActiveWorkbook.SaveAs Filename:= _
xlsDateipfad, FileFormat:= _
xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
Application.Run "Jet_MesswerteAusdünnen"
Application.Run "Jet_Diagramm"
End If
ActiveWorkbook.Close
Windows(Worksheetname).Activate
' Application.Wait (Now + TimeValue("00:01:00"))
n = n + 1
Loop
Set Worksheetname = Nothing
End Sub
Subroutine 2:
Option Explicit
Sub Jet_MesswerteAusdünnen()
Dim LZ, LS As Long 'letzter Zeile / letze Spalte
Dim TZ As Long 'Anzahl Messerte
Dim W As Long 'Anzahl Messerte die übrig bleiben sollen
Dim p100W As Single 'Anzahl Messwerte/gewünschte Anzahl Messwerte-1
Dim p1W As Single 'p100W-1(%von1)
Dim i, i0 As Long 'Schleifenzähler Zeilen
Dim j As Integer 'Schleifenzähler Spalten
Dim p As Long 'Ergebnis ohne Nachkommastellen
Dim ws As Worksheet
i0 = 39
TZ = ActiveSheet.UsedRange.Rows.Count
TZ = TZ - i0
W = 1000
If TZ Subroutine 3:
Option Explicit
Sub Jet_Diagramm()
Dim LS As Long
Dim DiaData As Range
Dim DN As String
Dim ws As Worksheet
DN = ActiveSheet.Name
LS = ActiveSheet.Cells(3, Columns.Count).End(xlToLeft).Column ' letzte belegte Spalte)
LS = (LS - 2) / 2 'Anzahl der Spalten (= Anzahl abgefragter Kanaale)
ActiveSheet.Range(Cells(1, LS + 3), Cells(1, LS + LS + 2)).Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWindow.ScrollRow = 32200
ActiveWindow.ScrollRow = 1
ActiveSheet.Range(Cells(1, LS + 3), Cells(32002, LS + LS + 2)).Name = "DiaData"
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlXYScatterSmoothNoMarkers
ActiveChart.SetSourceData Source:=Range("DiaData")
ActiveChart.Location Where:=xlLocationAsNewSheet
ActiveChart.Name = DN + "_Diagramm"
ActiveChart.Axes(xlValue, xlPrimary).HasTitle = True
ActiveChart.Axes(xlCategory, xlPrimary).HasTitle = True
ActiveChart.SetElement (msoElementChartTitleAboveChart)
ActiveChart.ChartTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 20
ActiveChart.ChartTitle.Select
ActiveChart.ChartTitle.Text = DN
Selection.Format.TextFrame2.TextRange.Characters.Text = DN
ActiveChart.Axes(xlValue).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 16
Selection.Format.TextFrame2.TextRange.Font.Bold = msoTrue
ActiveChart.Axes(xlValue, xlPrimary).AxisTitle.Text = "p in bar / T in °C / Spannung in V"
Selection.Format.TextFrame2.TextRange.Characters.Text = "p in bar / T in °C / Spannung in V" _
ActiveChart.Axes(xlCategory).AxisTitle.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 16
Selection.Format.TextFrame2.TextRange.Font.Bold = msoTrue
ActiveChart.Axes(xlCategory, xlPrimary).AxisTitle.Text = "t in s"
Selection.Format.TextFrame2.TextRange.Characters.Text = "t in s"
ActiveChart.Legend.Select
Selection.Format.TextFrame2.TextRange.Font.Size = 16
ActiveChart.Axes(xlValue).TickLabels.Font.Size = 16
ActiveChart.Axes(xlCategory).TickLabels.Font.Size = 16
ActiveWorkbook.Save
Set DiaData = Nothing
Set ws = Nothing
End Sub
Danke,
Fabio