Etwas schwieriges zum kopieren

Hallo zusammen,
ich hoffe das mir jemand helfen kann.
Ich habe die Musterdatei beigefügt.
Folgendes:
In der Sheet Gesamt stehen verschiedene Tabellen, zum Beispiel KK oder kpu, können später mehr
werden.
Die Namen stehen in der Spalte "C".Nun möchte ich die Tabellen mit dem Namen "KK" in die Sheet "KK aktuell" kopieren und
zwar sollen alle Tabellen mit "KK" gesucht werden und jedes mal untereinander in die Sheet "KK aktuell"
kopiert werden.
Die Tabellen sollen nicht in der Gesamt-Sheet gelöscht werden.
Allerdings sollten vorher die "alten" Tabellen in der Sheet "KK aktuell" ab Zeile 10
gelöscht werden.
Jetzt kommt das Problem:
Die Tabellenausschnitte können in der Länge unterschiedlich sein, allerdings ist die
Breite immer gleich.
Beim Beispiel "KK" "B10 bis L23" oder "B25 bis L33".
Die Länge wird immer in der Spalte D ermittelt.
Geht sowas ?
Also die 1.Tabelle (Ausschnitt) "KK" ist B10:L23, 2. B25:L33, 3. B65:L71 .
https://www.herber.de/bbs/user/74980.xls
mfg Kurt P

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Private Sub CommandButton1_Click() '--- Tabellen KK kopieren --- DoIt "KK" End Sub Private Sub CommandButton2_Click() '--- Tabellen kpu kopieren --- DoIt "kpu" End Sub Sub DoIt(strT As String) Dim lngZ As Long, qq As Long, lngQ As Long Dim wsZ As Worksheet, strK As String, lngV As Long Set wsZ = Sheets(strT & " aktuell") With wsZ lngZ = .Cells(.Rows.Count, 4).End(xlUp).Row If lngZ > 9 Then .Rows(10).Resize(lngZ - 9).Delete End With With Sheets("Gesamt") lngQ = .Cells(.Rows.Count, 4).End(xlUp).Row lngZ = 10 For qq = 10 To lngQ + 1 If .Cells(qq, 3) = strT Then If lngV = 0 Then lngV = qq ElseIf qq > lngQ Or _ (.Cells(qq, 3) "" And .Cells(qq, 3) strT) Then If lngV > 0 Then .Cells(lngV, 2).Resize(qq - lngV, 11).Copy wsZ.Cells(lngZ, 2) lngZ = lngZ + qq - lngV lngV = 0 End If End If Next qq End With End Sub

Sub DoIt(strT As String) Dim lngZ As Long, qq As Long, lngQ As Long Dim wsZ As Worksheet, strK As String, lngV As Long '---- erst die alten Daten löschen --------------- Set wsZ = Sheets(strT & " aktuell") 'hier der Name des Sheets With wsZ lngZ = .Cells(.Rows.Count, 4).End(xlUp).Row 'Bereich Länge finden If lngZ > 9 Then .Rows(10).Resize(lngZ - 9).Delete 'Alte Daten löschen End With '---- jetzt wird kopiert ------------------------- With Sheets("Gesamt") lngQ = .Cells(.Rows.Count, 4).End(xlUp).Row lngZ = 10 For qq = 10 To lngQ + 1 If .Cells(qq, 3) = strT Then If lngV = 0 Then lngV = qq ElseIf qq > lngQ Or _ (.Cells(qq, 3) "" And .Cells(qq, 3) strT) Then If lngV > 0 Then .Cells(lngV, 2).Resize(qq - lngV, 11).Copy wsZ.Cells(lngZ, 2) lngZ = lngZ + qq - lngV lngV = 0 End If End If Next qq End With End Sub

Sub DoIt(strT As String) Dim lngZ As Long, qq As Long, lngQ As Long Dim wsZ As Worksheet, strK As String, lngV As Long '---- erst die alten Daten löschen --------------- Set wsZ = Sheets(strT & " aktuell") 'hier der Name des Sheets With wsZ lngZ = .Cells(.Rows.Count, 4).End(xlUp).Row 'Bereich Länge finden If lngZ > 9 Then .Rows(10).Resize(lngZ - 9).Delete 'Alte Daten löschen End With '---- jetzt wird kopiert ------------------------- With Sheets("Gesamt") lngQ = .Cells(.Rows.Count, 4).End(xlUp).Row ' letzte Quell-Zeile lngZ = 10 ' erste Ziel-Zeile For qq = 10 To lngQ + 1 ' Schleife über Quelltab. If .Cells(qq, 3) = strT Then ' KK oder kpu in Sp. C? If lngV = 0 Then lngV = qq ' lngV = Zeile, ab der kopiert wird ' merken, wenn lngV = 0 ist ElseIf qq > lngQ Or _ (.Cells(qq, 3) "" And .Cells(qq, 3) strT) Then ' wenn in Sp. C etwas anderes steht, ' müssen die Zeilen darüber kopiert werden, ' wenn lngV nicht 0 ist. If lngV > 0 Then ' Kopiere .Cells(lngV, 2).Resize(qq - lngV, 11).Copy wsZ.Cells(lngZ, 2) lngZ = lngZ + qq - lngV ' berechne nächste Zielzeile lngV = 0 ' danach: suche neues KK oder kpu in Sp. C End If End If Next qq End With End Sub

Hi Kurt,
können wir davon ausgehen, dass der Code im Modul des Tabellenblatts "Muster" steht,
also nicht in einem "normalen" Modul (wie Modul1)?
Wenn dem so iost, wird in dem Code
Sheets("Aktuell").Select
lRow1 = Cells(Rows.Count, 4).End(xlUp).Row
lRow1 als letzte Zeile inh Spalte D des Blattes "Muster" bwerechnet, nicht jedoch des Blattes "Aktuel".
Das überrascht auf den ersten Blick, wurde doch davor "Aktuell" per Select aktiviert, ist aber so.
"Cells" beszieht sich auf das Tabellenblatt, zu dem der Code gehört - und das muss nicht das aktive Blatt sein.
Aus diesem Grund hatte ich in meinem Code immer With-Klammern um die Anweisungen.
Damit (und dem Punkt z. B. vor Cells) ist immer klar, welches Blatt angesprochen ist.
Grundsätzlich ist mir jetzt überhaupt nicht klar, um welchen Code es jetzt eigentlich geht.
Bei meinem Code ging es um Blätter "Gesamt", "KK aktuell", "xyz aktuell", ab Zielzeile 10.
Jetzt geht es um "Muster" und "Aktuell". Bist du noch am selben Problem?
Wenn du die letzte Zeile in Aktuell!D:D ermitteln willst, dann besser so:


With Sheets("Aktuell")
lRow1 = .Cells(.Rows.Count, 4).End(xlUp).Row
end with

Die Punkte sind wichtig.
Wofür ist die Zeile "az = ActiveCell"? Was ist az, wie ist das deklariert?
Der Copy-Befehl könnte evtl. so aussehen:
Sheets("Muster").Range("10:47").Copy Sheets("Aktuell").Cells(lRow1 + 2, 1)
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

With Sheets("Aktuell") lRow1 = .Cells(.Rows.Count, 4).End(xlUp).Row Sheets("Muster").Range("10:47").Copy .Cells(lRow1 + 2, 1) .Select ' falls "Aktuell" nicht aktives Blatt ist .Cells(lRow1 + 2, 1).Select End With

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Etwas schwieriges zum kopieren

22 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

22
Beiträge zum Forumthread

Beiträge zu diesem Forumthread