Inhalte von Spalte A in erste freie Zeile nach Spalte B kopieren
22.10.2019 14:31:45
Spalte
vermutlich beschreibt mein Betreff nicht 100%ig worum es in meinem Hilferuf geht. Den möchte ich euch im Folgenden kurz erklären.
Ich habe in einem Dokument zwei Tabellen ("Zieltabelle" und "Quelltabelle"). Per Makro möchte ich aus "Quelltabelle" die Inhalte bestimmter Spalten in "Zieltabelle" kopieren. Dabei wird nach vordefinierten Spaltenüberschriften in "Quelltabelle" gesucht, und bei Übereinstimmung dementsprechend übertragen.
Nun kommen wir zu meinem Problem. In "Zieltabelle" können in der ersten Zeile nach der Spaltenüberschrift Werte stehen. Wenn dem so ist, soll der vorher kopierte Inhalt aus "Quelltabelle" in "Zieltabelle" in die erste freie Zeile darunter (nach den vorhandenen Werten) eingefügt werden. Es klappt aber nicht so, wie ich es möchte. Ich komme über einmal einfügen unter die Spaltenüberschrift nicht hinaus.
Hier mein Code:
Public Sub Makro1()
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim rZelle As Range, rZiel As Range
Dim aUeberschr As Variant
Dim iIndx As Integer
aUeberschr = Array("zählpunktNummer", "geraeteartText", "herstellerText", " _
geraetetypbezeichnung", "status", "verbrauchsstelleAnwohner", "verbrauchsstelleAnschriftStrasse")
'Hier kommen später noch weitere zu prüfende Spaltenüberschriften
Application.ScreenUpdating = False
Set wsSource = Worksheets("Quelltabelle") 'das Quell-Tabellenblatt
Set wsDestination = Worksheets("Zieltabelle") 'das Ziel-Tabellenblatt
For iIndx = 0 To UBound(aUeberschr)
'Array wird Schritt für Schritt durchlaufen
Set rZelle = wsSource.Rows(1).Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:=xlValues)
'rZelle soll in "Quelltabelle" ab Zeile 1 die jeweilige Überschrift aus dem definierten _
Array finden
If Not rZelle Is Nothing Then
'rZelle hat eine Überschrift aus dem Array in "Quelltabelle" gefunden
Set rZiel = wsDestination.Rows(4).Find(aUeberschr(iIndx), LookAt:=xlWhole, LookIn:= _
xlValues)
'rZiel soll nun in "NA-Geräte" auch nach den im Array definierten Überschriften suchen
If Not rZiel Is Nothing Then
'rZiel hat eine Übereinstimmung gefunden
wsSource.Range(rZelle.Rows(2), rZelle.End(xlDown)).Copy
'rZelle soll die Spalte mit gefundene Überschrift aus "Quelltabelle" ab Zeile 2 bis _
zum letzten Wert in dieser Spalte
kopieren
wsDestination.Range(rZiel(2), rZiel.End(xlDown)).PasteSpecial Paste:=xlPasteValues
'Funktioniert gut, aber nur wenn noch keine Informationen in "Zieltabelle" stehen. Der _
kopierte Bereich soll nun in die
erste freie Zeile in der Spalte mit der übereinstimmenden Überschrift eingefügt werden _
'Alternative, die allerdings die kopierten Inhalte in die Spaltenüberschriften _
schreibt und nicht in die erste freie Zeile
darunter -> wsDestination.Range(rZiel.End(xlDown), rZiel.End(xlToRight)).PasteSpecial _
Paste:=xlPasteValues
End If
End If
Next iIndx
'Nimm nun die nächste Spaltenüberschrift
Application.ScreenUpdating = True
End Sub
Der Hammer wäre es, wenn man dann noch definieren könnte, dass beim 2., 3., etc. Durchlauf die jeweiligen Spalteninhalte immer auf einer Ebene geschrieben werden. Falls es leere Zeilen gibt, kann sich der Inhalt irgendwann nach Oben verschieben und die Inhalte aus "Quelltabelle" sind in "Zieltabelle" nicht mehr auf einer Ebene. Aber das ist gerade noch nicht so wichtig.
Über eure Hilfe wäre ich wirklich dankbar!
VG, Anne