Vorhandes Makro meldet Laufzeitfehler 7
18.01.2014 17:50:07
Daniel
ich habe ein Makro, dass mir immer wieder einen Laufzeitfehler 7 "Nicht genügend Speicher" anzeigt, natürlich immer dann, wenn man das das Makro braucht und nicht beim Testen :).
Das Makro wandelt eine Liste von aktuell 12.000 Zeilen mit einzelnen Werten in 3.000 Spalten in eine Tabelle um, die ich mit Pivottabellen weiterverarbeite.
Dabei habe ich Begriffe in Zeilen, die verschiedenen Kategorien in den Spalten mit einem "x" zugeordnet werden. Das Makro fügt dann auf einem neuen Tabellenblatt eine Zeile für jeden Begriff und jede Kategorie ein.
Grösse der Datei ist aktuell ca. 7 MB, mein Rechner läuft mit MS Excel 32Bit, Win8 64Bit, 8 GB Arbeitsspeicher und einem I7 Intel-Prozessor.
Während der Arbeit an der Excel sind andere Programme geschlossen, damit der begrenzte Arbeitsspeicher, der von Excel 32Bit verwendet wird, möglichst dafür zur Verfügung steht.
Folgende Zeilen des Makros werden beim Debuggen angezeigt:
arrQ = .Range(.Cells(1, 1), .Cells(ZeileQ, SpalteQ))
und
MsgBox "Umgruppieren der Daten erfordert mehr als 100000 Zeilen", _
Einmal kommt die eine Zeile, ein anderes mal die andere Zeile, Gründe warum mal die eine oder mal die andere Zeile entziehen sich meiner Kenntnis.
Kann mir jemand sagen, warum mir diese beiden Zeilen immer wieder Probleme machen?
Merci
Daniel
Hier das vollständige Makro:
Sub Daten_Pivotgerecht_Alle()
'Optimiert für große Datenmengen durch Verwendung von Daten-Arrays
'Überträgt die Daten des aktiven Tabellenblatts in ein neues Blatt,
'so dass Pivot-Auswertung möglich wird.
Dim wksQ As Worksheet, wksZ As Worksheet
Dim strBegriff As String, varWert(1 To 16) As Variant
Dim strUkat As String, strUUkat As String, varKategorie As Variant
Dim ZeileQ As Long, SpalteQ As Long, ZeileZ As Long
Dim bolKategorie As Boolean
Dim arrQ As Variant, arrZ() As Variant
Const cAnzWerte As Integer = 16 'Anzahl der Spalten in Zieltabelle
Const cZeileKat As Long = 1 'Nummer der Zeile mit den Kategorien - diese Nummer ggf. anpassen
Const cSpa_Wert1 As Long = 15 'Nummer der Spalte 1. Wert OII
Const cSpa_Wert2 As Long = 16 'Nummer der Spalte 2. Wert Begriff
Const cSpa_Wert3 As Long = 17 'Nummer der Spalte 3. Wert
Const cSpa_Wert4 As Long = 18 'Nummer der Spalte 4. Wert
Const cSpa_Wert5 As Long = 19 'Nummer der Spalte 5. Wert
Const cSpa_Wert6 As Long = 20 'Nummer der Spalte 6. Wert
Const cSpa_Wert7 As Long = 21 'Nummer der Spalte 7. Wert
Const cSpa_Wert8 As Long = 22 'Nummer der Spalte 8. Wert
Const cSpa_Wert9 As Long = 23 'Nummer der Spalte 9. Wert
Const cSpa_Wert10 As Long = 24 'Nummer der Spalte 10. Wert
Const cSpa_Wert11 As Long = 25 'Nummer der Spalte 11. Thema
Const cSpa_Wert12 As Long = 26 'Nummer der Spalte 12. Thematik
Const cSpa_Begriff As Long = 9 'Nummer der Spalte mit Begriffen
Const cSpa_UKat As Long = 13 'Nummer der Spalte Unter-Kategorie
Const cSpa_UUKat As Long = 14 'Nummer der Spalte Unter-Unter-Kategorie
Const cSpa_Kat1 As Long = 58 'Nummer der Spalte der 1. Kategorie
Set wksQ = ActiveSheet
If MsgBox("Daten des aktiven Tabellenblatts """ & wksQ.Name & """ für Pivotauswertung _
aufbereiten?", _
vbQuestion + vbOKCancel, "Makro: Daten_Pivotgerecht_Alle") = vbCancel Then Exit Sub
Application.ScreenUpdating = False
'Neues Blatt einfügen für umgruppierte Daten
With wksQ.Parent
.Worksheets.Add after:=wksQ
End With
Set wksZ = ActiveSheet
ZeileZ = 1
'Array für die Zieldaten überdimensionert anlegen
ReDim arrZ(1 To cAnzWerte, 1 To 100000)
arrZ(1, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Begriff) '"Begriff"
arrZ(2, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert1) '"Wert 1"
arrZ(3, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert2) '"Wert 2"
arrZ(4, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert3) '"Wert 3"
arrZ(5, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert4) '"Wert 4"
arrZ(6, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert5) '"Wert 5"
arrZ(7, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert6) '"Wert 6"
arrZ(8, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert7) '"Wert 7"
arrZ(9, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert8) '"Wert 8"
arrZ(10, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert9) '"Wert 9"
arrZ(11, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert10) '"Wert 10"
arrZ(12, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert11) '"Wert 11"
arrZ(13, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_Wert12) '"Wert 12"
arrZ(14, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_UKat) '"Unter-Kategorie"
arrZ(15, ZeileZ) = wksQ.Cells(cZeileKat, cSpa_UUKat) '"Unter-Unter-Kategorie"
arrZ(16, ZeileZ) = "Kategorie"
'Array mit den Quelldaten füllen
With wksQ
SpalteQ = .Cells(cZeileKat, .Columns.Count).End(xlToLeft).Column
ZeileQ = .Cells(.Rows.Count, cSpa_Begriff).End(xlUp).Row
arrQ = .Range(.Cells(1, 1), .Cells(ZeileQ, SpalteQ))
End With
For ZeileQ = cZeileKat + 1 To UBound(arrQ, 1) 'startzeile ggf. anpassen
strBegriff = CStr(arrQ(ZeileQ, cSpa_Begriff))
varWert(1) = arrQ(ZeileQ, cSpa_Wert1)
varWert(2) = arrQ(ZeileQ, cSpa_Wert2)
varWert(3) = arrQ(ZeileQ, cSpa_Wert3)
varWert(4) = arrQ(ZeileQ, cSpa_Wert4)
varWert(5) = arrQ(ZeileQ, cSpa_Wert5)
varWert(6) = arrQ(ZeileQ, cSpa_Wert6)
varWert(7) = arrQ(ZeileQ, cSpa_Wert7)
varWert(8) = arrQ(ZeileQ, cSpa_Wert8)
varWert(9) = arrQ(ZeileQ, cSpa_Wert9)
varWert(10) = arrQ(ZeileQ, cSpa_Wert10)
varWert(11) = arrQ(ZeileQ, cSpa_Wert11)
varWert(12) = arrQ(ZeileQ, cSpa_Wert12)
strUkat = "'" & CStr(arrQ(ZeileQ, cSpa_UKat))
strUUkat = "'" & CStr(arrQ(ZeileQ, cSpa_UUKat))
bolKategorie = False
For SpalteQ = cSpa_Kat1 To UBound(arrQ, 2)
If LCase(arrQ(ZeileQ, SpalteQ)) = "x" Then
ZeileZ = ZeileZ + 1
arrZ(1, ZeileZ) = strBegriff
arrZ(2, ZeileZ) = varWert(1)
arrZ(3, ZeileZ) = varWert(2)
arrZ(4, ZeileZ) = varWert(3)
arrZ(5, ZeileZ) = varWert(4)
arrZ(6, ZeileZ) = varWert(5)
arrZ(7, ZeileZ) = varWert(6)
arrZ(8, ZeileZ) = varWert(7)
arrZ(9, ZeileZ) = varWert(8)
arrZ(10, ZeileZ) = varWert(9)
arrZ(11, ZeileZ) = varWert(10)
arrZ(12, ZeileZ) = varWert(11)
arrZ(13, ZeileZ) = varWert(12)
arrZ(14, ZeileZ) = strUkat
arrZ(15, ZeileZ) = strUUkat
arrZ(16, ZeileZ) = arrQ(cZeileKat, SpalteQ) 'Kategorie - Zeilennummer in Quelle ggf. _
anpassen
bolKategorie = True
End If
Next
If bolKategorie = False Then
'keine Kategorie ist angekreuzt
ZeileZ = ZeileZ + 1
arrZ(1, ZeileZ) = strBegriff
arrZ(2, ZeileZ) = varWert(1)
arrZ(3, ZeileZ) = varWert(2)
arrZ(4, ZeileZ) = varWert(3)
arrZ(5, ZeileZ) = varWert(4)
arrZ(6, ZeileZ) = varWert(5)
arrZ(7, ZeileZ) = varWert(6)
arrZ(8, ZeileZ) = varWert(7)
arrZ(9, ZeileZ) = varWert(8)
arrZ(10, ZeileZ) = varWert(9)
arrZ(11, ZeileZ) = varWert(10)
arrZ(12, ZeileZ) = varWert(11)
arrZ(13, ZeileZ) = varWert(12)
arrZ(14, ZeileZ) = strUkat
arrZ(15, ZeileZ) = strUUkat
arrZ(16, ZeileZ) = "'"
End If
If ZeileZ = 20000 Then
MsgBox "Umgruppieren der Daten erfordert mehr als 100000 Zeilen", _
vbInformation + vbOKOnly, "M A K R O - A B B R U C H"
GoTo Beenden
End If
Next ZeileQ
ReDim Preserve arrZ(1 To cAnzWerte, 1 To ZeileZ)
Beenden:
'umgruppierte Daten in Zieltabelle eintragen
With wksZ
.Range(.Cells(1, 1), .Cells(ZeileZ, cAnzWerte)) = Application.WorksheetFunction.Transpose( _
_
arrZ)
.Columns.AutoFit
End With
Range("A2").Select
ActiveWindow.FreezePanes = True
Application.ScreenUpdating = True
If IsArray(arrQ) Then Erase arrQ
If IsArray(arrZ) Then Erase arrZ
End Sub