AW: VBA weniger Arbeitsspeicher nutzen möglich?
13.03.2015 18:52:03
fcs
Hallo Jonas,
das Problem könnten die Einstellungen/Optionen für die Zwischenablage sein.
1. die Option "Sammeln ohne Anzeige der Office-Zwischenablage" muss deaktiviert werden
2. das Zwischenablage-Fenster muss während der Makroausführung ausgeblendet sein.
Den 2. Punkt kann man noch per Makro steuern. Siehe unten.
Ansonsten wimmelt es in deinem Makro von Activate- und Select-Anweisungen mit Umschaltungen zwischen Arbeitsmappen und Tabellenblättern. Das alles schlägt schwer durch auf die Datenverwaltung von Excel. Ich hab mal versucht dein Makro in der Richtung zu bereinigen, indem entsprechende Objekt-Variablen verwendet werden, aber kann keine Garantie für Funktion geben - das kann man nur am leben Objekt durchtesten.
Die Gleichzeitige Verwaltung von mehr als 15 gleichzeitig geöffneten Dateien mit scheinbar jeweils mehr als 1500 Datenzeilen kann schwer auf den Arbeitsspeicher und die größe der Auslagerungsdatei durchschlagen.
Du solltest auch mal die UsedRange in den Tabellen prüfen, ob diese wesentlich größer ist als der eigentlich mit Daten ausgefüllte Zellbereich. Wenn ja, dann solltest du deine Tabellen mal aufräumen und und nicht benötigte Zellbereiche rechts und unterhalb der eigentlichen Daten mal komplett löschen.
Guß
Fanz
'Damit das Clipboard die Makro-Kopieraktionen nicht übernimmt muss die Option _
"Sammeln ohne Anzeige der Office-Zwischenablage" deaktiviert werden.
Sub Test_Makro1()
'Variablen-Deklarationen
Dim StatusClipboard As Boolean 'Merker für Status
'weiter Deklarationen
'Clipboard-Fenster in Excel ggf. ausblenden
StatusClipboard = Application.CommandBars("Office Clipboard").Visible
If StatusClipboard = True Then
Application.CommandBars("Office Clipboard").Visible = False
End If
'Code ....
'Clipboard-Fenster in Excel ggf. wieder einblenden
If StatusClipboard Application.CommandBars("Office Clipboard").Visible Then
Application.CommandBars("Office Clipboard").Visible = StatusClipboard
End If
End Sub
Sub Test_Makro_Anfang()
Dim i As Integer, z As Integer, b As Integer, f As Integer, r As Integer, y As Integer
Dim wkb_A2_z_P As Workbook
Dim wks_A2_z_P As Worksheet, wks_A2_z_P_Ziel As Worksheet
Dim wkbAusgang As Workbook, wksAusgang As Worksheet, wksAusgang_Quelle As Worksheet
Dim StatusClipboard As Boolean, StatusCalc As Long
Dim lngZahl As Long
Set wkbAusgang = Windows("Ausgangsdatei.xlsm")
Set wksAusgang = wkbAusgang.Sheets("Ausgangsblatt")
'Makrobremsen lösen
With Application
StatusClipboard = .CommandBars("Office Clipboard").Visible
If StatusClipboard = True Then
.CommandBars("Office Clipboard").Visible = False
End If
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.EnableEvents = False
End With
For z = 1 To 15
Set wkb_A2_z_P = Application.Workbooks("A2-" & z & "P.xlsm")
' wkb_A2_z_P.Activate '?
For i = 1 To wkb_A2_z_P.Sheets.Count
Set wks_A2_z_P = wkb_A2_z_P.Sheets(i)
' wks_A2_z_P.Select '?
'Cells.Select ' NICHT NOTWENDIG
' wks_A2_z_P.Range("I1").Activate '?
With wks_A2_z_P
.Rows.Hidden = False
.Columns.Hidden = False
.Columns("M:M").ClearContents
If .ChartObjects.Count 0 Then
For lngZahl = .ChartObjects.Count To 1 Step -1
.ChartObjects(lngZahl).Delete
Next lngZahl
End If
End With
' wkbAusgang.Activate '?
' wkbAusgang.Sheets("Ausgangsblatt").Select '?
wksAusgang.Range("B:B").EntireColumn.Copy 'Spalte B:B
' wkb_A2_z_P.Activate '?
wks_A2_z_P.Columns(2).Insert Shift:=xlToRight
Application.CutCopyMode = False
' wkbAusgang.Activate '?
wksAusgang.Range("O:Y").EntireColumn.Copy Destination:=wks_A2_z_P.Columns("O1")
' wkb_A2_z_P.Activate '?
Application.CutCopyMode = False
wks_A2_z_P.Range("O:Y").EntireColumn.AutoFit
' wkbAusgang.Activate '?
' wksAusgang.Select '?
wksAusgang.ChartObjects("Diagramm 7").Chart.ChartArea.Copy
' wkb_A2_z_P.Activate '?
wks_A2_z_P.Paste
Application.CutCopyMode = False
With wks_A2_z_P.Shapes(wks_A2_z_P.ChartObjects(1).Name)
.Top = wks_A2_z_P.Range("U4").Top
.Left = wks_A2_z_P.Range("U4").Left
End With
With wks_A2_z_P.ChartObjects(1).Chart
'ActiveChart.PlotArea.Select '-überflüssig
.SeriesCollection(1).XValues = "='" & wks_A2_z_P.Name & "'!$B$3:$B$1503"
.SeriesCollection(1).Values = "='" & wks_A2_z_P.Name & "'!$D:$D"
.SeriesCollection(2).XValues = "='" & wks_A2_z_P.Name & "'!$B$3:$B$1503"
.SeriesCollection(2).Values = "='" & wks_A2_z_P.Name & "'!$O:$O"
.SeriesCollection(3).XValues = "='" & wks_A2_z_P.Name & "'!$B$3:$B$1503"
.SeriesCollection(3).Values = "='" & wks_A2_z_P.Name & "'!$P:$P"
.SeriesCollection(4).XValues = "='" & wks_A2_z_P.Name & "'!$R$4:$R$153"
.SeriesCollection(4).Values = "='" & wks_A2_z_P.Name & "'!$S:$S"
.SeriesCollection(5).XValues = "='" & wks_A2_z_P.Name & "'!$B$3:$B$1503"
.SeriesCollection(5).Values = "='" & wks_A2_z_P.Name & "'!$V:$V"
.SeriesCollection(6).XValues = "='" & wks_A2_z_P.Name & "'!$R$4:$R$153"
.SeriesCollection(6).Values = "='" & wks_A2_z_P.Name & "'!$X:$X"
End With
' ?ClearClipboard = True ? 'da kommt bei mir eine Fehlermeldung
Application.CutCopyMode = False
Next i
b = wkb_A2_z_P.Sheets.Count
r = b + 1
With wkb_A2_z_P
.Sheets.Add After:=.Sheets(.Sheets.Count)
Set wks_A2_z_P_Ziel = .Sheets(.Sheets.Count)
End With
' wks_A2_z_P_Ziel.Select '?
wks_A2_z_P_Ziel.Name = "Fnetto"
' wkbAusgang.Activate '?
Set wksAusgang_Quelle = wkbAusgang.Sheets("fnetto")
' wksAusgang_Quelle.Select '?
wksAusgang_Quelle.ChartObjects("Diagramm 1").Copy
' wkb_A2_z_P.Activate '?
' wks_A2_z_P_Ziel.Select '?
wks_A2_z_P_Ziel.Paste
Application.CutCopyMode = False
For f = 1 To b
With wks_A2_z_P_Ziel.ChartObjects(1).Chart
With .SeriesCollection(f)
.XValues = "='" & wkb_A2_z_P.Sheets(f).Name & "'!$B$3:$B$1503"
.Values = "='" & wkb_A2_z_P.Sheets(f).Name & "'!$D:$D"
.Name = wkb_A2_z_P.Sheets(f).Name
End With
End With
Next f
'Hier habe ich die Blätter r=b+2 bis b+6 ausgeblendet
r = b + 7
With wkb_A2_z_P
.Sheets.Add After:=.Sheets(.Sheets.Count)
Set wks_A2_z_P_Ziel = .Sheets(.Sheets.Count)
End With
' wks_A2_z_P_Ziel.Select '?
wks_A2_z_P_Ziel = "Dehnviskosität über Weg"
' wkbAusgang.Activate '?
Set wksAusgang_Quelle = wkbAusgang.Sheets("fnetto")
' wksAusgang_Quelle.Select '?
wksAusgang_Quelle.ChartObjects("Diagramm 1").Copy
' wkb_A2_z_P.Activate '?
' wks_A2_z_P_Ziel.Select '?
wks_A2_z_P_Ziel.Paste
Application.CutCopyMode = False
For f = 1 To b
With wks_A2_z_P_Ziel.ChartObjects(1).Chart
With .SeriesCollection(f)
.XValues = "='" & Sheets(f).Name & "'!$R$4:$R$153"
.Values = "='" & Sheets(f).Name & "'!$X:$X"
.Name = Sheets(f).Name
End With
.ChartTitle.Text = "Dehnviskosität über Weg"
End With
Next f
Next z
'Makrobremsen zurücksetzen
With Application
If StatusClipboard .CommandBars("Office Clipboard").Visible Then
.CommandBars("Office Clipboard").Visible = StatusClipboard
End If
.ScreenUpdating = True
.Calculation = StatusCalc
.EnableEvents = True
End With
End Sub