Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1592to1596
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

ListObjects

ListObjects
27.11.2017 11:45:39
Gina
https://www.herber.de/bbs/user/117937.xlsm
Hallo Zusammen,
ich bin neu im Forum weil ich ein VBA Anfänger bin.
Ich komme bei meiner Datei einfach nicht weiter siehe Beispieldatei beigefügt.
Meine codes funktionieren soweit gut nur weiß ich nicht wie ich Sie mit Listobjects, Listrow, Databodyrange umschreiben soll. Meine Versuche scheitern.
Meine codes sollen aus drei definierte Tabellen auf drei Tabellenblätter aufgeteilt: Zeilen wenn Bedingungen erfüllt sind verschieben und löschen. Funktioniert soweit gut nur das die Zeilen nicht in der definierten Tabelle landen und somit dann meine VBA Filter nicht mehr greifen können.
Hier meine codes um die es geht:
Sub clean_QRM_DoneLaterDueDate1Month()  'löscht alle Zeile deren Definition: QRM, Status: Done  _
und due date: älter als 1 Monat zum Heutigem Datum
Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim EndDate As Long
EndDate = DateSerial(Year(Date), Month(Date), Day(Date) - 30) 'definiert Datum von Heute minus  _
1 Monat
With ThisWorkbook.Worksheets("FPI QRM")
ZeileMax = .Cells(Rows.Count, 1).End(xlUp).Rows.Row
n = 0   'flex für MessageBox keinen neuen QRMs zum löschen
For Zeile = ZeileMax To 7 Step -1   'sucht nach letzter beschriebenen Zeile von unten  _
damit keine übersprungen wird auch mit leerzeilen
If .Cells(Zeile, 1).Value = "QRM" Then   'sucht in spalte 1 (Definition) nach Wert  _
QRM wenn ja dann
If .Cells(Zeile, 8).Value = "Done" Then 'sucht in spalte 8 (Status) nach Wert  _
Done wenn ja dann
If .Cells(Zeile, 9).Value 
Sub Grade_Definition()   'verschiebt alle Zeile mit Definition: action, ins Blatt actions und lö _
scht im Blatt QRM
Dim Zeile As Long
Dim ZeileMax1, Zeilemax2 As Long
Dim n As Long
With ThisWorkbook.Worksheets("FPI QRM")
ZeileMax1 = .Cells(Rows.Count, 1).End(xlUp).Rows.Row
n = 0
For Zeile = ZeileMax1 To 7 Step -1
If .Cells(Zeile, 1).Value = "action" Then
Zeilemax2 = Worksheets("FPI actions").Cells(Rows.Count, 1).End(xlUp).Rows.Row
Zeilemax2 = Zeilemax2 + 1
.Rows(Zeile).Copy Destination:=Worksheets("FPI actions").Rows(Zeilemax2)
.Rows(Zeile).EntireRow.Delete shift:=xlUp
n = 1
End If
Next Zeile
End With
If n = 0 Then
MsgBox "no new actions to moved to page FPI actions"
Else
MsgBox "all new actions sihfted to page FPI actions"
End If
End Sub

Sub Archive_Action_ClosedKilled()    'verschiebt alle Zeile mit Status closed und killed ins  _
Blatt archive und löscht im Blatt actions
Dim Zeile As Long
Dim ZeileMax1, Zeilemax2 As Long
Dim n As Long
With ThisWorkbook.Worksheets("FPI actions")
ZeileMax1 = .Cells(Rows.Count, 8).End(xlUp).Rows.Row
n = 0
For Zeile = ZeileMax1 To 7 Step -1
If .Cells(Zeile, 8).Value = "Closed" Then
Zeilemax2 = Worksheets("archive").Cells(Rows.Count, 1).End(xlUp).Rows.Row
Zeilemax2 = Zeilemax2 + 1
.Rows(Zeile).Copy Destination:=ThisWorkbook.Worksheets("archive").Rows(Zeilemax2)
n = 1
.Rows(Zeile).EntireRow.Delete shift:=xlUp
End If
Next Zeile
For Zeile = ZeileMax1 To 7 Step -1
If .Cells(Zeile, 8).Value = "Killed" Then
Zeilemax2 = Worksheets("archive").Cells(Rows.Count, 1).End(xlUp).Rows.Row
Zeilemax2 = Zeilemax2 + 1
.Rows(Zeile).Copy Destination:=ThisWorkbook.Worksheets("archive").Rows(Zeilemax2)
n = 1
.Rows(Zeile).EntireRow.Delete shift:=xlUp
End If
Next Zeile
End With
If n = 0 Then
MsgBox "no new Closed actions for archive"
Else
MsgBox "all Closed/Killed actions sihfted to page archive"
End If
End Sub

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: ListObjects
27.11.2017 17:54:36
fcs
Hallo Gina,
mit den Tabelle/ListObjects zu arbeiten ist eigentlich nicht so schwer.
Problem: Man muss auch berücksichtigen, dass die Tabelle ggf. noch keine Datenzeilen beinhaltet.
https://www.herber.de/bbs/user/117952.xlsm
Ich hab in deiner Datei die 3 Makros so umgestellt, das zur Bestimmung der Maxzeilen und der der letzten Zeile der For-Next-Schleifen das Tabellenobjekt verwendet wird.
Für die Zieltabellen wird nach dem Kopieren/Einfügen der Zeilen zusätzlich ggf. der Datenbereich der Tabellen neu festgelegt, so das der Autofilter alle Datenzeilen beinhaltet.
Gruß
Franz
Sub clean_QRM_DoneLaterDueDate1Month()  'löscht alle Zeile deren Definition: QRM, Status: Done  _
und due date: älter als 1 Monat zum Heutigem Datum
Dim Zeile As Long
Dim ZeileMax As Long
Dim n As Long
Dim EndDate As Long
Dim objListQRM As ListObject
EndDate = DateSerial(Year(Date), Month(Date), Day(Date) - 30) 'definiert Datum von Heute  _
minus 1 Monat
With ThisWorkbook.Worksheets("FPI QRM")
Set objListQRM = .ListObjects(1)
objListQRM.AutoFilter.ShowAllData
If objListQRM.DataBodyRange Is Nothing Then
MsgBox "Keine Daten in Tabelle im Blatt """ & .Name & """ vorhanden!", _
vbOKOnly, "Makro: clean_QRM_DoneLaterDueDate1Month"
End If
ZeileMax = objListQRM.Range.Row + objListQRM.DataBodyRange.Rows.Count
n = 0   'flex für MessageBox keinen neuen QRMs zum löschen
For Zeile = ZeileMax To objListQRM.Row + 1 Step -1 'sucht nach letzter beschriebenen  _
Zeile von unten damit keine übersprungen wird auch mit leerzeilen
If .Cells(Zeile, 1).Value = "QRM" Then   'sucht in spalte 1 (Definition) nach Wert  _
QRM wenn ja dann
If .Cells(Zeile, 8).Value = "Done" Then 'sucht in spalte 8 (Status) nach Wert  _
Done wenn ja dann
If .Cells(Zeile, 9).Value  .Range.Row + ZeilenDR2 Then
.Resize .Range.Range("A1").Resize(Zeilemax2 - .Range.Row + 1, .Range.Columns.Count)
End If
End With
If n = 0 Then
MsgBox "no new actions to moved to page FPI actions"
Else
MsgBox "all new actions sihfted to page FPI actions"
End If
End Sub
Sub Archive_Action_ClosedKilled()    'verschiebt alle Zeile mit Status closed und killed ins  _
Blatt archive und löscht im Blatt actions
Dim Zeile As Long
Dim ZeileMax1 As Long, Zeilemax2 As Long, ZeilenDR1 As Long, ZeilenDR2 As Long
Dim n As Long
Dim objListArchive As ListObject, objListAction As ListObject
With ThisWorkbook.Worksheets("archive")
If .ListObjects.Count = 0 Then
MsgBox "Bitte erst in Blatt """ & .Name & """ das Tabellenobjekt einfügen!", _
vbInformation + vbOKOnly, "Makro: Archive_Action_ClosedKilled"
Exit Sub
End If
Set objListArchive = .ListObjects(1)
objListArchive.AutoFilter.ShowAllData
End With
With objListArchive
ZeilenDR2 = 0
If Not .DataBodyRange Is Nothing Then
ZeilenDR2 = .DataBodyRange.Rows.Count
End If
Zeilemax2 = .Range.Row + ZeilenDR2
End With
With ThisWorkbook.Worksheets("FPI actions")
Set objListAction = .ListObjects(1)
objListAction.AutoFilter.ShowAllData
With objListAction
ZeilenDR1 = 0
If Not .DataBodyRange Is Nothing Then
ZeilenDR2 = .DataBodyRange.Rows.Count
End If
ZeileMax1 = .Range.Row + ZeilenDR2
End With
n = 0
For Zeile = ZeileMax1 To objListAction.Range.Row + 1 Step -1
If .Cells(Zeile, 8).Value = "Closed" Then
Zeilemax2 = Zeilemax2 + 1
.Rows(Zeile).Copy Destination:=ThisWorkbook.Worksheets("archive").Rows( _
Zeilemax2)
n = 1
.Rows(Zeile).EntireRow.Delete shift:=xlUp
End If
Next Zeile
With objListAction
ZeilenDR1 = 0
If Not .DataBodyRange Is Nothing Then
ZeilenDR1 = .DataBodyRange.Rows.Count
End If
ZeileMax1 = .Range.Row + ZeilenDR1
End With
For Zeile = ZeileMax1 To objListAction.Range.Row + 1 Step -1
If .Cells(Zeile, 8).Value = "Killed" Then
Zeilemax2 = Zeilemax2 + 1
.Rows(Zeile).Copy Destination:=ThisWorkbook.Worksheets("archive").Rows( _
Zeilemax2)
n = 1
.Rows(Zeile).EntireRow.Delete shift:=xlUp
End If
Next Zeile
End With
With objListArchive
'Listenbereich ggf. neu festlegen
If Zeilemax2 > .Range.Row + ZeilenDR2 Then
.Resize .Range.Range("A1").Resize(Zeilemax2 - .Range.Row + 1, .Range.Columns.Count)
End If
End With
If n = 0 Then
MsgBox "no new Closed actions for archive"
Else
MsgBox "all Closed/Killed actions sihfted to page archive"
End If
End Sub

Anzeige
AW: ListObjects
27.11.2017 21:03:29
Gina
Hallo Franz,
das ging ja schnell!
Vielen Dank auch für die Verständliche Erklärung!
Gina

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige