AW: Blattname
11.08.2021 15:19:33
Patricia
Noch eine Frage:
Ich bekomme nun immer eine Fehlermeldung, dass ich nicht genügend Speicherkapazität hätte, wenn ich dieses Makro laufen lasse.
Meistens ist es bei der 1. Schleife.
Ist das möglich, braucht das so viel Speicher? Könnte ich das irgendwie anders schreiben oder liegt das wirklich am Speicherproblem?
Vielleicht seht ihr etwas das man viel einfacher codieren könnte..?
Sub copy_and_convert_table()
Dim letzteZeile As Long
Dim i As Long
Dim rng As Range
Dim tbl As ListObject
Dim tbl_original As Worksheet
'Bestehende Tabelle löschen
tbl_copy.Select
letzteZeile = tbl_copy.Cells(Rows.Count, 1).End(xlUp).Row
tbl_copy.Range("A1:aa" & letzteZeile).Clear
'Tabellennamen vergeben
Set tbl_original = Worksheets(tbl_Makro.Range("a4").Value)
'Neue Tabelle kopieren
With tbl_original
letzteZeile = .Cells(Rows.Count, "M").End(xlUp).Row
.Range("a1:ag" & letzteZeile).Copy Destination:=tbl_copy.Range("a1")
End With
'Spalte entfernen wenn leer in Zelle A
With tbl_copy
.Select
letzteZeile = .Cells(Rows.Count, 11).End(xlUp).Row
For i = 2 To letzteZeile
If .Range("a" & i).Value = "" Then
.Rows(i).Delete
End If
If .Range("k" & i).Value = "SUBTOTAL" Then
.Rows(i).Delete
End If
Next i
End With
With tbl_copy
.Select
'Concatenate PO&Supplier
letzteZeile = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("aa2").Formula2Local = "=(f2&"" - ""&e2) "
.Range("aa2").Copy Destination:=.Range("aa3:aa" & letzteZeile)
'find/replace pending with PO pending
.UsedRange.Replace what:="pending", replacement:="OP pending"
'Bereich in Tabelle umwandeln
Set rng = .Range("a1:aa" & letzteZeile)
Set tbl = .ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium15"
'Tabelle benennen
tbl.Name = "newTable"
'Spaltenüberschrift = Text
.Range("aa1").Value = "item text"
'Spalte AA = Autofit
.Columns("A:AA").EntireColumn.AutoFit
'Tabelle sortieren nach currency
.ListObjects("newTable").Sort.SortFields.Clear
.ListObjects("newTable").Sort.SortFields.Add _
Key:=.Range("newTable[[#All],[Currency]]"), _
SortOn:=xlSortOnValues, _
Order:=xlAscending, _
DataOption:=xlSortNormal
With tbl_copy.ListObjects("newTable").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
With tbl_Zusammenzug
'Bestehende Werte Blatt Zusammenzug löschen
letzteZeile = tbl_Zusammenzug.UsedRange.SpecialCells(xlCellTypeLastCell).Row
.Range("a1:n" & letzteZeile).Clear
End With
'Werte nach Blatt Zusammenzug kopieren
With tbl_copy
letzteZeile = tbl_copy.UsedRange.SpecialCells(xlCellTypeLastCell).Row
.Range("h2:h" & letzteZeile).Copy
tbl_Zusammenzug.Range("a2").PasteSpecial xlPasteValues
tbl_Zusammenzug.Range("a1").Value = "Currency"
.Range("r2:r" & letzteZeile).Copy
tbl_Zusammenzug.Range("c2").PasteSpecial xlPasteValues
tbl_Zusammenzug.Range("c1").Value = "GL account"
.Range("a2:a" & letzteZeile).Copy
tbl_Zusammenzug.Range("b2").PasteSpecial xlPasteValues
tbl_Zusammenzug.Range("b1").Value = "company code"
.Range("aa2:aa" & letzteZeile).Copy
tbl_Zusammenzug.Range("d2").PasteSpecial xlPasteValues
tbl_Zusammenzug.Range("d1").Value = "item text"
.Range("l2:l" & letzteZeile).Copy
tbl_Zusammenzug.Range("e2").PasteSpecial xlPasteValues
tbl_Zusammenzug.Range("e1").Value = "Debit"
.Range("t2:t" & letzteZeile).Copy
tbl_Zusammenzug.Range("k2").PasteSpecial xlPasteValues
tbl_Zusammenzug.Range("k1").Value = "cost center"
tbl_Zusammenzug.Range("K2:k" & letzteZeile).Columns.TextToColumns Destination:=tbl_Zusammenzug.Range("k2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
.Range("u2:u" & letzteZeile).Copy
tbl_Zusammenzug.Range("m2").PasteSpecial xlPasteValues
tbl_Zusammenzug.Range("m1").Value = "order number"
tbl_Zusammenzug.Range("m2:m" & letzteZeile).Columns.TextToColumns Destination:=tbl_Zusammenzug.Range("m2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
End With
'Alles Autofit
tbl_Zusammenzug.Columns("A:n").EntireColumn.AutoFit
'leere Spalte wenn Währung ändert
With tbl_Zusammenzug
letzteZeile = .Cells(Rows.Count, 1).End(xlUp).Row
For i = letzteZeile To 3 Step -1
If .Range("a" & i).Value .Range("a" & i - 1).Value Then
.Rows(i & ":" & i).Insert Shift:=xlDown
End If
Next i
'Text einfügen
letzteZeile = .Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To letzteZeile + 1
If .Range("d" & i).Value = "" Then
.Range("c" & i).Value = tbl_upload.Range("g11").Value
End If
Next i
End With
tbl_upload.Select
tbl_upload.Columns("b:n").EntireColumn.AutoFit
tbl_Zusammenzug.Select
tbl_Zusammenzug.Range("a1").Select
End Sub