Copy von Listobject zu Listobject

Sub Filter_Kopieren() Application.ScreenUpdating = False Archiv.ListObjects("tbl_archiv").ListRows.Add AlwaysInsert:=True 'Variablen dimensionieren Dim rng As Range 'Tabelle in Range einlesen Set rng = Tabelle8.ListObjects("Tabelle1").Range 'Autofilter setzen rng.AutoFilter 15, "Ja" 'Gefilterte Tabelle kopieren ActiveSheet.ListObjects("Tabelle1").DataBodyRange.Copy Archiv.ListObjects("tbl_archiv").DataBodyRange ActiveWorkbook.SlicerCaches("Datenschnitt_Meldung__Z_P_1").ClearManualFilter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub t() Dim loQuelle As ListObject, loZiel As ListObject Dim lR As ListRow Set loQuelle = Tabelle8.ListObjects("Tabelle1") Set loZiel = Archiv.ListObjects("tbl_archiv") loQuelle.Range.AutoFilter 15, "Ja" Set lR = loZiel.ListRows.Add loQuelle.DataBodyRange.Copy lR.Range End Sub

Sub test1() Dim rg As Range On Error Resume Next Set rg = ActiveSheet.ListObjects("Tabelle1") _ .DataBodyRange.SpecialCells(xlVisible) On Error GoTo 0 If rg Is Nothing Then MsgBox "gefiltertes ListObjekt hat keine Daten" Else 'mach was End If End Sub

Hallo Fritz,
Luschi war schneller. Ich packe solche Check zweck Fehlertoleranz, die nur innerhalb eines Sub/Function gilt, immer in separaten Function.
Da ein "Trick" für den sichtbaren Bereich eines LO gefunde habe, poste ich trotzdem. Siehe Version 1 & 2: sichtbaren Bereich kann man mit Range("TabX[#Data]") markieren.


Sub Makro4()
Dim loQuelle As ListObject
Dim loZiel As ListObject
Dim LR As ListRow
'Init
Set loQuelle = ActiveSheet.ListObjects("Tabelle1")
Set loZiel = ActiveSheet.ListObjects("Tabelle13")
'Filter
loQuelle.Range.AutoFilter 'Reset Filters
loQuelle.Range.AutoFilter Field:=2, Criteria1:="Jan"
'Test & Copy
If CellTypeVisible_zählen(loQuelle) Then
Set LR = loZiel.ListRows.Add
'Version 1:
loQuelle.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy LR.Range
'Version 2:
'        loQuelle.Parent.Range("Tabelle1[#Data]").Copy LR.Range
End If
'Reset Filter
loQuelle.Range.AutoFilter
End Sub
Private Function CellTypeVisible_zählen(ByRef LO As ListObject) As Long
'bleibt null, falls keine Zeilen sichtbar
On Error Resume Next
CellTypeVisible_zählen = LO.DataBodyRange.SpecialCells(xlCellTypeVisible).Rows.Count
End Function

VG
Yal

Sub Filter_Kopieren() Application.ScreenUpdating = False Dim loQuelle As ListObject, loZiel As ListObject Dim LR As ListRow Dim i As Integer Set loQuelle = Tabelle8.ListObjects("Tabelle1") Set loZiel = Archiv.ListObjects("tbl_archiv") loQuelle.Range.AutoFilter 15, "Ja" i = MsgBox("Sollen Daten, die an XYZ gesendet wurden, archiviert werden?", vbYesNo, "Archivierung") If i = vbNo Then MsgBox "Daten wurden nicht kopiert!", vbCritical, "Achtung" Exit Sub ElseIf i = vbYes Then Set LR = loZiel.ListRows.Add loQuelle.DataBodyRange.Copy LR.Range MsgBox "Daten wurden kopiert", vbOKOnly = ok, "Archiv" Application.DisplayAlerts = False loQuelle.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete Application.DisplayAlerts = True End If Tabelle8.Select ActiveWorkbook.SlicerCaches("Datenschnitt_Meldung__Z_P_1").ClearManualFilter End Sub

Sub t() Dim loQuelle As ListObject, loZiel As ListObject Dim lR As ListRow Set loQuelle = Tabelle8.ListObjects("Tabelle1") Set loZiel = Archiv.ListObjects("tbl_archiv") With loQuelle .AutoFilter.ShowAllData If .ListRows.Count = 0 Then MsgBox "Tabelle ist leer" Exit Sub End If If WorksheetFunction.CountIf(.ListColumns(15).DataBodyRange, "Ja") = 0 Then MsgBox "keine Daten, welche dem Kriterium entsprechen" Exit Sub End If If MsgBox("Sollen Daten, die an XYZ gesendet wurden, archiviert werden?", vbYesNo, "Archivierung") = vbYes Then .Range.AutoFilter 15, "Ja" Set lR = loZiel.ListRows.Add .DataBodyRange.Copy lR.Range Application.DisplayAlerts = False .DataBodyRange.SpecialCells(xlCellTypeVisible).Delete Application.DisplayAlerts = True .AutoFilter.ShowAllData MsgBox "Daten wurden kopiert", vbOKOnly, "Archiv" Else MsgBox "Daten wurden nicht kopiert!", vbCritical, "Achtung" End If End With End Sub

Beliebteste Forumthreads (12 Monate)

Copy von Listobject zu Listobject

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread