Office: wieder Visual Basic

Hallo meine Lieben,
ich hab mal wieder ein Problem mit VB.
Ich hab einen Code der mir hilft Tabellen in andere Blätter zu kopieren und das nicht in die Tabelle gehörende zu löschen. Nun hab ich das Problem das ich zwei Tabellen auf einem Blatt hab, allerdings nur nebeneinander. Ich würde diese aber gern untereinander haben, bekommen es allerdings nicht hin.
hier mal der Code den ich im Moment verwende:

Private Sub Worksheet_Activate()
'Die Suchkriterien werden eingetragen:
Range("y1") = "Kartennummer"
Range("y2") = "*CP01-DE*"
Range("y3") = "Kartennummer"
Range("y4") = "*CP02-DE*"
'Der Spezialfilter wird angewendet:
Sheets("Namensortierung").Columns("A:O").AdvancedFilter Action:=xlFilterCopy _
, CriteriaRange:=Range("y1:y2"), CopyToRange:=Columns("A:F"), Unique:=False
'Der Spezialfilter wird angewendet:
Sheets("Namensortierung").Columns("A:O").AdvancedFilter Action:=xlFilterCopy _
, CriteriaRange:=Range("y3:y4"), CopyToRange:=Columns("H:M"), Unique:=False
'Die unzutreffenden Einträge aus Spalte C werden gelöscht:
Dim Arr, i As Long, j As Long
On Error Resume Next
For i = 2 To UsedRange.Rows.Count
Arr = Split(Cells(i, 3), Chr(10))
For j = 0 To UBound(Arr)
If InStr(Arr(j), "CP01-DE") = 1 Then Exit For
Next j
Cells(i, 3) = Arr(j)
Next i
'Die unzutreffenden Einträge aus Spalte I werden gelöscht:
Dim Arr1, y As Long, z As Long
On Error Resume Next
For y = 2 To UsedRange.Rows.Count
Arr1 = Split(Cells(y, 10), Chr(10))
For z = 0 To UBound(Arr1)
If InStr(Arr1(z), "CP02-DE") = 1 Then Exit For
Next z
Cells(y, 10) = Arr1(z)
Next y
'Die Spalten A:F werden nach Spalte C sortiert:
Range("A:F").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Die Spalten A:F werden nach Spalte I sortiert:
Range("H:M").Sort Key1:=Range("I1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Die Spalten H:M werden unter die erste Tabelle gesetzt

End Sub

Wie ihr seht wollt ich das druntersetzen am Ende machen, aber wenn ihr eine bessere Stelle wisst dann helft mir bitte.

mfg
adpar

 

Ohne ein Beispiel, wie es aussieht und wie es aussehen soll ist es etwas reichlich mühsam, sich da durchzuwurschteln. Aber vielleicht mal als ganz anderen Ansatz:

Kopieren zweier Spalten in eine andere:

Code:

y3act=2
x3min=3:x3max=3

y1min=2:y1max=123
x1min=1:x1max=1
for y1=y1min to y1max
  if (true) then
    range(cells(y1,x1min),cells(y1,x1max)).copy destination:=range(cells(y3,x3min),cells(y3,x3max))
    y3act=y3act+1
  endif
next y1

y2min=2:y2max=234
x2min=2:x2max=2
for y2=y2min to y2max
  if (true) then
    range(cells(y2,x2min),cells(y2,x2max)).copy destination:=range(cells(y3,x3min),cells(y3,x3max))
    y3act=y3act+1
  endif
next y2

Das kopiert Dir alle Zellen aus Spalte A (x1min bis x1max), danach aus Spalte B (x2min bis x2max), und setzt diese untereinander in Spalte C (x3min bis x3max). Berücksichtigt werden dabei die Zeilen 2 bis 123 in Spalte A (y1min bis y1max) bzw. 2 bis 234 in Spalte B (y2min bis y2max). Das Einfügen der Werte beginnt in Zeile 2 der Spalte C (y3act).

Die Vorarbeit für diese beiden Schleifen:
* Anpassen der Werte y1min bis y3act, um die Bereiche auf dem Blatt zu spezifizieren.
* Anpassen der "if (true) then" Zeilen, um nur das Kopieren von "passenden" Zeilen zu erlauben.

Dann müßte das Ding eigentlich funktionieren. Ist allerdings so aus'm Stegreif jetzt, also völlig ungetestet.

Gruß, Michael

 

Danke für deine Mühe, aber das ist nicht das was ich verwenden kann.
Zur näheren Erläuterung.
In einem Tabellenblatt werden zwei Tabellen aus einer dritten Tabelle aus einem anderen Tabellenblatt zusammengestellt.
Das Problem ist, dass beide Tabellen unterschiedlich lang sein können, da sich die Daten in der Haupttabelle auch ständig ändern. Und da liegt das Problem.
ich möchte eigentlich nur das VB die erste leere Zeile in den Spalten A:F sucht, daraufhin die Tabelle die in den Spalten H:M steht "ausschneidet" und diese in die zweite Leere Zeile einfügt.
Aber das bekomme ich irgendwie nicht hin. :cry:

mfg
adpar

 

doch... ;-)

Du möchtest also y1max bzw. y2max bestimmen. Und das Ende der Tabelle ist durch die erste leere Zeile definiert. Mit

Code:

end(xldown)

kommst du von der aktuellen Zelle in die letzte belegte Zelle unterhalb. Dann hast Du auch die Zeile der letzten belegten Zelle:

Code:

y1max=cells(y1min,x1min).end(xldown).row

Und wenn Du die 2. direkt unter die 1. Tabelle kopieren willst, statt eine 3. Tabelle zu erstellen, dann setzt Du y3act und x3min/max entsprechend:

Code:

y3act=y1max+1
x3min=x1min
x3max=x1max

und überspringst die 1. Schleife.

Gruß, Michael

 

Ich hab den Code so genommen wie du es mir geschrieben hast, aber nun kopiert er mir nur Spalte B in Spalte A unter die erste Tabelle.
Ich brauch aber die Spalten H-M in den Spalten A-F. Außerdem brauch ich auch eine Leerzeile zwischen den beiden tabellen damit ich später weiss wo die eine aufhört und die andere anfängt.

Private Sub Worksheet_Activate()
'Die Suchkriterien werden eingetragen:
Range("y1") = "Kartennummer"
Range("y2") = "*CP01-DE*"
Range("y3") = "Kartennummer"
Range("y4") = "*CP02-DE*"
'Der Spezialfilter wird angewendet:
Sheets("Namensortierung").Columns("A:O").AdvancedFilter Action:=xlFilterCopy _
, CriteriaRange:=Range("y1:y2"), CopyToRange:=Columns("A:F"), Unique:=False
'Der Spezialfilter wird angewendet:
Sheets("Namensortierung").Columns("A:O").AdvancedFilter Action:=xlFilterCopy _
, CriteriaRange:=Range("y3:y4"), CopyToRange:=Columns("H:M"), Unique:=False
'Die unzutreffenden Einträge aus Spalte C werden gelöscht:
Dim Arr, i As Long, j As Long
On Error Resume Next
For i = 2 To UsedRange.Rows.Count
Arr = Split(Cells(i, 3), Chr(10))
For j = 0 To UBound(Arr)
If InStr(Arr(j), "CP01-DE") = 1 Then Exit For
Next j
Cells(i, 3) = Arr(j)
Next i
'Die unzutreffenden Einträge aus Spalte I werden gelöscht:
Dim Arr1, y As Long, z As Long
On Error Resume Next
For y = 2 To UsedRange.Rows.Count
Arr1 = Split(Cells(y, 10), Chr(10))
For z = 0 To UBound(Arr1)
If InStr(Arr1(z), "CP02-DE") = 1 Then Exit For
Next z
Cells(y, 10) = Arr1(z)
Next y
'Die Spalten A:F werden nach Spalte C sortiert:
Range("A:F").Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Die Spalten A:F werden nach Spalte I sortiert:
Range("H:M").Sort Key1:=Range("I1"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Die Spalten H:M werden unter die erste Tabelle gesetzt
Dim y1 As Long
Dim y1min As Long
Dim x1min As Long
Dim y1max As Long
Dim x1max As Long

Dim y2 As Long
Dim y2min As Long
Dim x2min As Long
Dim y2max As Long
Dim x2max As Long

Dim y3act As Long
Dim x3min As Long
Dim x3max As Long

y1min = 2
x1min = 1
y1max = Cells(y1min, x1min).End(xlDown).Row
x1max = 1

y2min = 2
x2min = 2
y2max = Cells(y2min, x2min).End(xlDown).Row
x2max = 2

y3act = y1max + 1
x3min = x1min
x3max = x1max

loop1:
GoTo loop2
For y1 = y1min To y1max
If (True) Then
Range(Cells(y1, x1min), Cells(y1, x1max)).Copy Destination:=Range(Cells(y3act, x3min), Cells(y3act, x3max))
y3act = y3act + 1
End If
Next y1

loop2:
For y2 = y2min To y2max
If (True) Then
Range(Cells(y2, x2min), Cells(y2, x2max)).Copy Destination:=Range(Cells(y3act, x3min), Cells(y3act, x3max))
y3act = y3act + 1
End If
Next y2
End Sub

mfg
adpar

 

Und damit macht es genau das, was ich schrieb. ;-)

Und ich schrieb in einem vorherigen Posting:

Die Spalten H..M sind numerisch die Spalten 8..13 (x2min, x2max) und die Spalten A..F sind 1..6 (x1min, x1max). Und wenn "direkt dran" nicht soll, sondern "eine mehr", dann ist es eben y3act=y1max+2 statt +1...

Die ganze Geschichte hab ich doch extra so auf parametrisierte Funktion ausgelegt, daß man eigentlich so ziemlich jede beliebige Kombination hinbekommt, ohne den Ablauf grundlegend ändern zu müssen.

Gruß, Michael

 

hay!
Jetzt hab ich es zum größten Teil verstanden und auch hinbekommen.
Nur der letzte Teil will mir noch nicht einleuchten:

Wenn du mir den nochmal erklähren könntest wäre ich dir sehr dankbar.
Denn gelöscht bekommei ch die Tabelle noch nicht, er macht erst mal nur eine kopie.

mfg
adpar

 

Nun, der 1. Ansatz nimmt die 1. Tabelle (x1) und kopiert sie an eine neue Stelle (x3), danach die 2. Tabelle (x2) und kopiert sie ebenfalls an die neue Stelle (x3) unten dran.

Wenn Du jetzt die 2. Tabelle (x2) direkt unter die 1. (x1) haben willst, brauchst Du die 1. ja nicht erst woanders hin kopieren. Also entfällt der 1. Schleifendurchlauf und die Zielkoordinaten für den 2. Lauf sind eben direkt unterhalb der 1. Tabelle - also wird x3 passend zu x1 gesetzt.

Code:

Denn gelöscht bekommei ch die Tabelle noch nicht, er macht erst mal nur eine kopie.

Das wiederum ist ein anderes Paar Schuhe. Wenn Du verschieben statt kopieren möchtest. Ersetze einfach in den 2 Schleifen ".Copy" durch ".Cut" und es wird direkt verschoben.

Gruß, Michael

 

Vielen lieben Dank.
Nun hab ich es kapiert und den Code angepasst.
Bist ein echt toller Lehrer.
Hier nochmal mein veränderter Codefür alle die es interessiert:

Wie du siehst hab ich ein paar weitere komponenten hinzugefügt um die Überschrift mit zu kopieren und einen Laufzeitfehler zu vermeiden.

Nochmal ganz herzlichen Dank!!!

mfg
adpar

 

Wenn Du während des Verschiebens keine Tests mehr machen mußt, ob die jeweilige Zeile überhaupt verschoben oder doch besser ignoriert werden soll, dann könntest Du noch die "if (true) then" und die dazu gehörenden "end if" jeweils mit einem ' auskommentieren. Das steigert die Geschwindigkeit geringfügig, weil dann eine überflüssige "wenn ja dann ja" nicht mit abgearbeitet werden muß.

(Für Puristen: Das komplette Löschen der Zeilen, um auch das Abarbeiten einer Kommentarzeile zu verhindern, ist natürlich die konsequenteste Methode...)

Gruß, Michael