mehrere Tabellen untereinander kopieren

[WeisserWolf611]

Hallo Leute,

ich verzweifel an der Umsetzung einer eigentlich einfachen Idee.
Ich habe mal die DEMO angehägt, damit es deutlich wird was ich machen will.
Die grünen Reiter sind das Ausgangsprodukt, hier können auch mal 60 Reiter vorhanden sein. (verbundene Zellen sind ein Horror, ich weiß, aber das ist leider so vorgegeben)
Die beiden blauen Reiter sind mein zu erzielendes Ergebnis.

Ich möchte ein Makro aufrufen, welches den Inhalt jeder grünen Tabelle (außer der ersten beiden grünen und der blauen blauen) im Bereich C9-C77 kopiert und im Reiter "Liste" untereinander weg einfügt.
Wahrscheinlich macht es Sinn die blauen an den Anfang zu schieben und das Makro ab Tabelle 5 anfangen zu lassen.
Zur Not geht es auch  mit den Leerzellen und am Ende über Filter löschen. Hier scheitert es schon daran, dass die QUelle ungleich zum Ziel formatiert ist. Ich muss nur die Werte reinkopiert haben, ohne die Formeln in B & C zu überschreiben. 
Eventuell ist der Aufbau auch einfach zu kompliziert, bin da für Verbesserungen offen :)

.Ich hoffe es ist irgendwie klar was ich vorhabe. Falls nicht beantworte ich sämtliche Fragen.

Vielen vielen Dank im Vorraus.

LG
Wolf

[WeisserWolf611]

Kurzer Nachtrag:

Mir ist grade bewusst geworden, dass die blauen Reiter am Ende bleiben müssen, weil ich die grünen anhand ihrer Position nummerieren lasse:
Also in einer Zelle steht "=Nr" und im Namensmanger ist dafür folgendes hinterlegt:
"=VERGLEICH(TEIL(ZELLE("Dateiname";INDIREKT("A1"));FINDEN("[";ZELLE("Dateiname";INDIREKT("A1")));999);ARBEITSMAPPE.ZUORDNEN(1);0)"

Vielleicht kann man das auch umstricken. Ich zumindest nicht  :20:

[schauan]

Hallöchen

Deine 4 festen Sheets kannst Du in der Schleife ausnehmen.

If Sheets(i).name <> "Schilder" And Sheets(i).name <> ….


Wenn Du dann noch sortierst, bekommst Du auch die Leerzeichen weg.

[WeisserWolf611]

Hey,

vielen Dank, das ist schon mal ein guter Hinweis, das kannte ich auch noch nicht, aber es bringt mich leider nicht weiter.
Fürs programmieren habe ich echt zwei linke Hände, da krieg ich einfach nicht in meine Birne rein... :22:

Bisher kam ich immer damit klar, mir Schnipsel von überall her zusammen zu suchen und dann entsprechend anzupassen, aber da hier ist wohl zu speziell.

[atilla]

Hallo,

schau Dir den Code unten mal an und teste ihn.
Es gibt aber keine Kontrolle, ob schon kopiert wurde oder nicht.
Eigentlich sollte das vorher geprüft werden. Ich erkenne aber nicht, wie und an was man das feststellen könnte.

Code:

Sub TabellenKopierenUntereinander()
Dim i As Integer
Dim LRow As Long
Dim ArrAusschlussTabellen
Application.ScreenUpdating = False

'aus unten gelistete Tabellen wird nicht kopiert
ArrAusschlussTabellen = Array("Deckblatt", "A4H_N", "Zeichnungsverzeichnis", "Schilder", "Liste", _
                        "A4Q_N")
For i = 2 To Sheets.Count

     With Sheets(i)
         If Not IsNumeric(Application.Match(Sheets(i).Name, ArrAusschlussTabellen, 0)) Then
            .Range("C9:C77").Copy
            With Sheets("Liste") 'in diese Tabelle wird in Spalte A ab erste Freie eingefügt
               LRow = .Cells(Rows.Count, 1).End(xlUp).Row
               .Cells(LRow + 1, 1).PasteSpecial xlPasteValues
            End With
         End If
     End With
Next
Application.ScreenUpdating = True
End Sub

Im Code sind die Tabellen aus denen nicht kopiert werden darf gelistet. Siehe Kommentare im Code.

[WeisserWolf611]

Hallo Attila,

das ist ja der Oberkracher... Copy --> Paste --> läuft einwandfrei!

Ich habe noch immer nicht ganz verstanden, wie der Code funktioniert, aber ich arbeite weiter daran :)

Ich habe den Code jetzt um ein paar Zeilen erweitert:

Code:

    'Leerzeilen aufiltern und löschen
    Columns("A:A").Select
    Application.CutCopyMode = False
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$A$3000").AutoFilter Field:=1, Criteria1:="="
    Rows("3:3000").Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$A$3000").AutoFilter Field:=1
   
    'Formel für zweizeilige Kabelnummern vererben
    Range("C2:D2").Select
    Selection.AutoFill Destination:=Range("C2:D3000"), Type:=xlFillDefault
    Range("A1").Select

Bitte nicht hauen, euch bluten wahrscheinlich direkt die Augen  :20: 
Aber es funktioniert auf jeden Fall und ich verstehe was in den paar Zeilen abgeht   

Ich setze einen Filter, suche nach leeren Zeilen, makiere diese und lösche die Zeilen und entferne den Filter. Anschließend "vererbe" ich die Formel aus den Zellen C2 & D2 einfach pauschal bis 3000.

Sieht bis hierhin schon sehr gut aus, jetzt haut es mir den Reiter "Schilder" auseinander.
A1 = Liste!$C2&ZEICHEN(10)&Liste!$D2 <-- und diese Formel habe ich mir über ein paar Bläter gezogen und habe gehofft, dass es passt, aber leider nicht. :20: 

Wahrscheinlich verschwinden sämtliche Zellbezüge, durch das löschen der Leerzeilen. Sehe ich das richtig? Wenn ja wie zum Henker kann ich das umgehen?
Ich muss nicht zwingend die Leerzeilen löschen, ich könnte auch mit einer gefilterten Liste weiterarbeiten, aber dann haben meine Ausgabeblätter zu viele leere Schilder, das wäre Verschwendung.

Hast du oder jemand anderes, dazu eine Idee?

Vielen Dank im Vorraus.
Grüße
Wolf

[schauan]

Hallo Wolf,

das mit den Formeln und den Leerzeilen ist immer so eine Sache. Entweder man entfernt erst die Leerzeilen und setzt dann die Formeln, oder man kopiert den unter einer Leerzeile befindlichen Teil eine Zeile nach oben, ggf. mit der Option "Werte einfügen". Sollten in dem Teil auch Formeln sein, muss man diese ggf. ausnehmen.


Das kann man aber schon vor dem Programmieren manuell ausprobieren und schauen, was man beachten muss und wie man es am Besten anstellt. Wenn man dann einen passablen Ablauf hat kann man den ggf. aufzeichnen und anpassen.