Office: Zeile sortiert einfügen

Mc Santa · 15. Mai 2018

Ich habe das erste Makro ein wenig anders geschrieben und dazu eine zweite Sub, die nun das erste Makro für alle Tabellen auf dem Arbeitsblatt aufruft:
Code:

Option Explicit

Sub Sortieren_und_kopieren(ByVal strTableName As String, ByRef ws As Worksheet)

Set ws = ThisWorkbook.Worksheets("Tabelle1")
strTableName = "Main_Table"

ws.ListObjects(strTableName).Sort.SortFields. _
Add Key:=Range(strTableName & "[[#All],[Aktie]]"), SortOn:=xlSortOnValues, Order _
:=xlAscending, DataOption:=xlSortNormal

ws.ListObjects(strTableName).AutoFilter.ApplyFilter
ws.Range(strTableName & "[Aktuell]").EntireColumn.Insert Shift:=xlToRight

ws.Range(strTableName & "[Aktuell]").Copy
ws.Range(strTableName & "[Aktuell]").Offset(, -1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

End Sub

Sub ALLE_Sortieren_und_kopieren()

Dim Tbl As ListObject

For Each Tbl In ActiveSheet.ListObjects

Sortieren_und_kopieren Tbl.Name, ActiveSheet

Next Tbl
End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

dmnkw · 15. Mai 2018

Hey, funktioniert leider nicht, kann das daran liegen, dass nicht alle Tabellen auf dem gleichen Arbeitsblatt "Main_Table" heißen können, muss das evtl. mit einem Laufindex definiert sein?

Danke schonmal

Mc Santa · 15. Mai 2018

Die folgenden Zeilen müssen natürlich gelöscht werde, das ist mir leider zuvor nicht aufgefallen.
Code:

Set ws = ThisWorkbook.Worksheets("Tabelle1")
strTableName = "Main_Table"
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

dmnkw · 16. Mai 2018

Geht leider noch nicht, es kommt folgender Fehler:

Laufzeitfehler 1004: Die Insert-Methode des Range-Objektes konnte nicht ausgeführt werden

dmnkw · 17. Mai 2018

Ich habe jetzt noch mal vieles versucht, aber leider bin ich zu keiner Lösung gekommen, hoffe, dass es eine Möglichkeit gibt, das Problem zu beheben

Mc Santa · 17. Mai 2018

Ja gibt es bestimmt, bei mir hat alles funktioniert.

Kannst du den aktuellen Stand der Testmappe noch einmal hochladen?

dmnkw · 17. Mai 2018

Anbei die Datei bei der ich den Fehler bekomme, danke schonmal

dmnkw · 17. Mai 2018

Auch kommt immer ein Fehler, wenn man die Excel Tabelle mit dem Makro öffnet, erst kommt:

"Von Excel wurde unlesbarer Inhalt gefunden, wollen Sie den Inhalt dieser Arbeitsmappe wiederherstellen? Wenn Sie der Quelle vertrauen ... usw."

Und wenn ich auf Ja drücke kommt folgendes:
Entfernte Datensätze: Sortierung von /xl/tables/table1.xml-Part (Tabelle)

Hier die Datei auch nochmal ohne Makro

Mc Santa · 17. Mai 2018

Ah ich erkenne meinen Fehler, hier schon mal der korrigierte Code
Code:

Option Explicit

Sub Sortieren_und_kopieren(ByVal strTableName As String, ByRef ws As Worksheet)

'Sortieren
ws.ListObjects(strTableName).Sort.SortFields. _
Add Key:=Range(strTableName & "[[#All],[Aktie]]"), SortOn:=xlSortOnValues, Order _
:=xlAscending, DataOption:=xlSortNormal
ws.ListObjects(strTableName).AutoFilter.ApplyFilter

'Neue Spalte einfügen
ws.ListObjects(strTableName).ListColumns.Add Position:=ws.ListObjects(strTableName).ListColumns("Aktuell").Index

'Daten kopieren
ws.Range(strTableName & "[Aktuell]").Copy
ws.Range(strTableName & "[Aktuell]").Offset(, -1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False

End Sub

Sub ALLE_Sortieren_und_kopieren()

Application.ScreenUpdating = False

Dim Tbl As ListObject

For Each Tbl In ActiveSheet.ListObjects

Sortieren_und_kopieren Tbl.Name, ActiveSheet

Next Tbl

Application.ScreenUpdating = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Mc Santa · 18. Mai 2018

Und hier nun auch der Code, um eine bestehende Aktie wieder aus allen Tabellen des aktuellen Blattes zu löschen. Die Abfrage geht nur, wenn die Groß-und-Kleinschreibung beachtet wird.
Code:

Sub Aktie_aus_allen_Tabellen_löschen()

Dim strInput As String
Dim Tbl As ListObject
Dim strAktie As String

strInput = InputBox("Welche Aktie wollen Sie löschen?", "Löschung")

If Not strInput = "" Then

If vbYes = MsgBox("Wollen Sie die Aktie " & strInput & " wirklich löschen?", vbExclamation + vbYesNo) Then
For Each Tbl In ActiveSheet.ListObjects

Aktie_löschen strInput, Tbl.Name, ActiveSheet

Next Tbl
End If
End If
End Sub

Sub Aktie_löschen(strAktie As String, strTableName As String, ws As Worksheet)

Dim col
Dim i As Integer

col = ws.ListObjects(strTableName).ListColumns("Aktie").DataBodyRange

For i = LBound(col, 1) To UBound(col, 1)
If col(i, 1) = strAktie Then
ws.ListObjects(strTableName).ListRows(i).Delete
End If
Next i

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

dmnkw · 21. Mai 2018

Wunderbar, vielen lieben Dank, das erspart mir wirklich einiges an Handarbeit, funktioniert super!!!

dmnkw · 29. Mai 2018

Hier mit kleiner Verbesserung: (Änderung ist fettgedruckt)

Code:

Option Explicit

Sub Sortieren_und_kopieren(ByVal strTableName As String, ByRef ws As Worksheet)

'Sortieren
ws.ListObjects(strTableName).Sort.SortFields. _
Add Key:=Range(strTableName & "[[#All],[Aktie]]"), SortOn:=xlSortOnValues, Order _
:=xlAscending, DataOption:=xlSortNormal
ws.ListObjects(strTableName).AutoFilter.ApplyFilter
Worksheets(ActiveSheet.Name).Sort.SortFields.Clear

'Neue Spalte einfügen
ws.ListObjects(strTableName).ListColumns.Add Position:=ws.ListObjects(strTableName).ListColumns("Aktuell").Index

'Daten kopieren
ws.Range(strTableName & "[Aktuell]").Copy
ws.Range(strTableName & "[Aktuell]").Offset(, -1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Application.CutCopyMode = False

End Sub

Sub ALLE_Sortieren_und_kopieren()

Application.ScreenUpdating = False

Dim Tbl As ListObject

For Each Tbl In ActiveSheet.ListObjects

Sortieren_und_kopieren Tbl.Name, ActiveSheet

Next Tbl

Application.ScreenUpdating = True

End Sub
Klicke in dieses Feld, um es in vollständiger Größe anzuzeigen.

Office: Zeile sortiert einfügen

Zeile sortiert einfügen

Zeile sortiert einfügen

Zeile sortiert einfügen

Zeile sortiert einfügen

Zeile sortiert einfügen - Similar Threads - Zeile sortiert einfügen

Rangfolge stimmt nicht, doppelte Zeilen

Letzten drei Werte aus Zeile

Array inZeile schreiben

VBA-Code überspringt einzelne Zeilen

Nur sichtbare Zeilen zählen

Zeile Einfügen mit Bedingung Farbe der letzten Beschriebenen Zeile

VBA in einer Zeile zu lang