Spalten kopieren, wenn Bedingung erfüllt

Hallo zusammen,
ich komme leider mit dem Makro-Rekorder und älteren Beiträgen nicht weiter und hoffe, jemand kann mir helfen ein funktionierendes Makro zu erstellen.
In meiner Datei gibt es insgesamt 6 Blätter. Das erste Blatt ist eine Zusammenfassung ausgewählter Spalten der übrigen 5 Blätter. Zur besseren Übersicht habe ich eine Musterdatei angehängt.
Ich möchte, dass wenn in Zeile 1 auf den Blättern Tabelle2 - Tabelle6 etwas steht, die gesamte Spalte in das Blatt Zusammenfassung kopiert wird.
Beispiel: In Tabelle2 ist die Zeile 1 in Spalte A, B, D, E, F, H, I, K, Q gefüllt. Nur diese Spalten sollen dann ab Zeile 2 in das andere Blatt (Zusammenfassung) kopiert werden.
Im Blatt Zusammenfassung sollen die Inhalte von Tabelle2 im Bereich A3 bis H3 eingefügt werden.
Da ich immer nur 8 Spalten pro Tabelle in Zeile 1 markieren werde, habe ich die Einfügebereiche im Blatt Zusammenfassung farblich markiert und beschriftet.
Es kann vorkommen, dass ich auch mal in einer Tabelle keine Spalte kopieren möchte (also kein Kreuz in Zeile 1 mache). Diese wird dann übersprungen.
Hier die Musterdatei:
https://www.herber.de/bbs/user/138509.xlsm
Vielen Dank für eure Hilfe!
Hannes

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Schaltfläche1_Klicken() Dim ws As Worksheet, loSpalte As Long, loZeile As Long Dim raKopieren As Range, i As Long, z As Long z = 1 Application.ScreenUpdating = False For Each ws In ThisWorkbook.Worksheets If ws.Name "Zusammenfassung" Then With ws loSpalte = .Cells(1, .Columns.Count).End(xlToLeft).Column For i = 1 To loSpalte If UCase(.Cells(1, i)) = "X" Then loZeile = .Cells(.Rows.Count, loSpalte).End(xlUp).Row If raKopieren Is Nothing Then Set raKopieren = .Range(.Cells(2, i), .Cells(loZeile, i)) Else Set raKopieren = Union(raKopieren, .Range(.Cells(2, i), _ .Cells(loZeile, i))) End If End If Next i If Not raKopieren Is Nothing Then raKopieren.Copy Worksheets("Zusammenfassung").Cells(3, z).PasteSpecial _ Paste:=xlPasteValues End If Set raKopieren = Nothing z = z + 9 End With End If Next ws Application.CutCopyMode = False Set raKopieren = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

Spalten kopieren, wenn Bedingung erfüllt

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

349 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Spalten kopieren, wenn Bedingung erfüllt

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

349 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread