Datensätze in andere Tabellen kopieren

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Liste_druchgehen() Dim E Dim W As Worksheet With ThisWorkbook.Worksheets("Tabelle1").ListObjects("Tabelle1") For Each E In .ListColumns("Artikel").DataBodyRange.Cells Set W = SelectOrCreate(E) E.EntireRow.Copy W.Range("A99999").End(xlUp).Offset(1) Next End With End Sub Private Function SelectOrCreate(ByVal Blattname As String) As Worksheet Dim W As Worksheet On Error Resume Next Set W = Worksheets(Blattname) If W Is Nothing Then Set W = Worksheets.Add(After:=Worksheets(Worksheets.Count)) Worksheets("Tabelle1").Range("A1:AZ1").Copy W.Range("A1") W.Name = Blattname End If Set SelectOrCreate = W End Function

Sub Liste_druchgehen() Dim E Dim W As Worksheet With ThisWorkbook.Worksheets("Tabelle1").ListObjects("Tabelle1") For Each E In .ListColumns("Artikel").DataBodyRange.Cells If E.EntireRow.Visible Then Set W = SelectOrCreate(E) E.EntireRow.Copy W.Range("A99999").End(xlUp).Offset(1) End If Next End With End Sub Private Function SelectOrCreate(ByVal Blattname As String) As Worksheet Dim W As Worksheet On Error Resume Next Set W = Worksheets(Blattname) If W Is Nothing Then Set W = Worksheets.Add(After:=Worksheets(Worksheets.Count)) Worksheets("Tabelle1").Range("A1:AZ1").Copy W.Range("A1") W.Name = Blattname End If Set SelectOrCreate = W End Function

Private Function SelectOrCreate(ByVal Blattname As String) As Worksheet Dim W As Worksheet On Error Resume Next Set W = Worksheets(Blattname) If W Is Nothing Then Set W = Worksheets("Vorlage").Copy(After:=Worksheets(Worksheets.Count)) W.Name = Blattname End If Set SelectOrCreate = W End Function

Sub Liste_durchgehen() Dim E Dim W As Worksheet Dim R As Range With ThisWorkbook.Worksheets("Aufträge").ListObjects("Aufträge") For Each E In .ListColumns("Spalte18").DataBodyRange.Cells.SpecialCells(xlCellTypeVisible) Set W = SelectOrCreate(E) Set R = W.Range("D99999").End(xlUp) If R = "" Then Set R = R.End(xlUp).Offset(1) Else Set R = R.Offset(1) E.EntireRow.Range("B1:F1").Copy R.EntireRow.Range("D1") E.EntireRow.Range("I1:I1").Copy R.EntireRow.Range("K1") E.EntireRow.Range("O1:Q1").Copy R.EntireRow.Range("Q1") Next End With End Sub Private Function SelectOrCreate(ByVal Blattname As String) As Worksheet Dim W As Worksheet On Error Resume Next Set W = Worksheets(Blattname) If W Is Nothing Then Set W = Worksheets("Vorlage").Copy(After:=Worksheets(Worksheets.Count)) W.Name = Blattname End If Set SelectOrCreate = W End Function

Hallo Yal,
gerade habe ich es noch hinbekommen aus dem hier:


With ThisWorkbook.Worksheets("Aufträge").ListObjects("Aufträge")

das hier zu machen:


With ThisWorkbook.Worksheets("Aufträge").ListObjects("Aufträge1")

An der Stelle gab es einen Laufzeitfehler. Man lernt ja immer dazu und damit habe ich für mich herausgefunden dass hier ListObjects auf die Tabelle der Fertigungsaufträge zugreift, bzw. diese einliest.Natürlich gefällt es mir nicht, von VBA abhängig zu sein, gerade im Moment sehe ich allerdings kein Land das mit Formeln hinzubekommen. Ich beschäftige mich gerade nebenbei noch mit Power Query, wo ich durch viele Abfragen und Änderungen dann auch zum gewünschten Ergebnis komme. Allerdings weiß ich gerade noch nicht, ob ich diese dann auch in der gewünschten Form in meine Tabellen ausgeben kann und das dann vielleicht auch per Knopfdruck für den Benutzer einfach ausführbar..
Zurück zu deinem VBA-Code. Den nächsten Laufzeitfehler, den ich nun habe verstehe ich nun nicht mehr so einfach.


Set R = W.Range("D99999").End(xlUp)

ergibt den Laufzeitfehler 91: Objektvariable oder With-Blockvariable nicht festgelegt.
Was muss ich denn hier anpassen, bzw. worum geht es da?
Vielen Dank
und viele Grüße
Steve

Hallo Yal,
erstmal vielen Dank für die weitere Unterstützung!
Ich habe in der Tabelle Aufträge tatsächlich eine Änderung vollzogen, weshalb der Code so jetzt nicht mehr funktioniert hat. Ich habe vor der Artikelnummer noch 2 Spalten in die Tabelle genommen um im Power Query auf der selben Spaltenebene arbeiten zu können.
Unabhängig davon habe ich auch den von dir geschickten VBA-Code dementsprechend abgeändert und der sieht jetzt so aus:


Sub Liste_durchgehen()
Dim E
Dim W As Worksheet
Dim R As Range
With ThisWorkbook.Worksheets("Aufträge").ListObjects("Aufträge1")
For Each E In .ListColumns("Spalte19").DataBodyRange.Cells.SpecialCells(xlCellTypeVisible)
Set W = SelectOrCreate(E)
Set R = W.Range("D99999").End(xlUp)
If R = "" Then Set R = R.End(xlUp).Offset(1) Else Set R = R.Offset(1)
E.EntireRow.Range("C1:G1").Copy R.EntireRow.Range("D1")
E.EntireRow.Range("J1:J1").Copy R.EntireRow.Range("K1")
E.EntireRow.Range("N1:N1").Copy R.EntireRow.Range("O1")
E.EntireRow.Range("P1:R1").Copy R.EntireRow.Range("Q1")
Next
End With
End Sub
Private Function SelectOrCreate(ByVal Blattname As String) As Worksheet
Dim W As Worksheet
On Error Resume Next
Set W = Worksheets(Blattname)
If W Is Nothing Then
Set W = Worksheets("Vorlage").Copy(After:=Worksheets(Worksheets.Count))
W.Name = Blattname
End If
Set SelectOrCreate = W
End Function

Beim ausführen werden jetzt alle Datensätze grundsätzlich richtig verschoben. Darüber bin ich schon mal wirklich froh :) Sobald jetzt in der Spalte 19 der erste Datensatz ohne Eintrag auftaucht wird wieder Laufzeitfehler 91: Objektvariable oder With-Blockvariable nicht festgelegt. generiert. Ich habe eine Vorlage angelegt, es wird auch ein neues Blatt daraus generiert. Ohne Inhalt. Und dann kommt die Fehlermeldung.
Generell sollten Datensätze, die in der Spalte 19 noch keinen Eintrag haben dann auch nicht kopiert werden.
Weiterhin hatte ich vorgesehen, dass alle kopierten Datensätze in Spalte 22 ein Vermerk darüber bekommen, dass Sie schon kopiert wurden und dies auch im Makro berücksichtigt wird. Wenn ich das Makro nämlich nochmals ausführe werden alle Datensätze wieder dupliziert unten angefügt. Allerdings ist das Blatt Aufträge als fortlaufende Eingabe zu verstehen, deren Einträge immer nur einmal in das jeweilige Tabellenblatt gelegt werden darf, d.h. das Makro müsste auch prüfen, ob in der Spalte 22 der Vermerk schon da ist, und wenn ja, nicht kopieren.
Dann ist mir zuletzt noch aufgefallen, dass es super funktioniert nur die Daten, die kopiert werden sollen, einzufügen. Allerdings wird in der Zieltabelle die Formatierung überschrieben. Die Zieltabelle enthält aber für den weiteren Umgang mit den Daten wichtige bedingte Formatierungen und auch das grundsätzliche Format der Daten, die eingefügt werden. Die bedingte Formatierung geht verloren und teilweise werden Rahmen der Aufträge-Tabelle unglücklich mit eingefügt.
Es wäre toll, diese Probleme noch zu lösen und ich denke wenn die gelöst sind werde ich auch den VBA Code dafür verstehen.
Vielen vielen Dank dir erst einmal.
Grüße
Steve

Sub Liste_durchgehen() Dim E Dim W As Worksheet Dim R As Range With ThisWorkbook.Worksheets("Aufträge").ListObjects("Aufträge1") For Each E In .ListColumns("Spalte19").DataBodyRange.Cells.SpecialCells(xlCellTypeVisible) If E.Value "" Then Set W = SelectOrCreate(E) Set R = W.Range("D99999").End(xlUp) If R = "" Then Set R = R.End(xlUp).Offset(1) Else Set R = R.Offset(1) E.EntireRow.Range("C1:G1").Copy R.EntireRow.Range("D1") E.EntireRow.Range("J1:J1").Copy R.EntireRow.Range("K1") E.EntireRow.Range("N1:N1").Copy R.EntireRow.Range("O1") E.EntireRow.Range("P1:R1").Copy R.EntireRow.Range("Q1") End If Next End With End Sub

Sub Liste_durchgehen() Dim wZ As Worksheet Dim LR Dim Artikel As Range Dim Merker As Range ThisWorkbook.Activate With Worksheets("Aufträge").ListObjects("Aufträge1") For Each LR In .ListRows Set LR = LR.Range.EntireRow If Not LR.Hidden Then Set Artikel = Intersect(LR, .ListColumns("Spalte19").Range) Set Merker = Intersect(LR, .ListColumns("Spalte22").Range) If Merker.Value = "" Then Set wZ = SelectOrCreate(Artikel.Value) Set Z = wZ.Range("D99999").End(xlUp) If Z = "" Then Set Z = Z.End(xlUp).Offset(1) Else Set Z = Z.Offset(1) Set Z = Z.EntireRow Z.Range("D1:H1") = LR.Range("C1:G1").Value Z.Range("K1") = LR.Range("J1").Value Z.Range("O1") = LR.Range("N1").Value Z.Range("Q1:S1") = LR.Range("P1:R1").Value Merker.Value = "ü" Merker.Font.Name = "Wingdings" End If End If Next End With End Sub

Beliebteste Forumthreads (12 Monate)

Datensätze in andere Tabellen kopieren

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Datensätze in andere Tabellen kopieren

23 Beiträge zum Forumthread Beiträge zu diesem Forumthread

303 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

23
Beiträge zum Forumthread

Beiträge zu diesem Forumthread