Per Array Spalten finden und kopieren
31.10.2019 13:31:56
Anne
mein folgender Code funktioniert fast einwandfrei, auch dank dieses Forums. Wäre da nicht ein Problem, was mich schon total verrückt macht. Per Array suche ich nach definierten Spaltenüberschriften in "Quelltabelle", welche nicht nebeneinander angeordnet sind. Wenn diese gefunden wurden, soll der Inhalt unter der Spaltenüberschrift in "Zieltabelle" kopiert werden. Das geht solange bis der komplette Array abgearbeitet ist.
Dummerweise gibt es 4 Spaltenüberschriften, die in "Zieltabelle" nicht befüllt werden. Ich habe überall die korrekte/ identische Schreibweise geprüft, ich suche nur nach Inhalten und keinen Formatierungen etc. Ich habe einfach keine Ahnung, wieso es nicht funktioniert.
Diese Begriffe werden zwar gefunden, aber nicht kopiert in "Zieltabelle": "verbrauchsstelleAnschriftPlz", "verbrauchsstelleAnschriftOrt", "verbrauchsstelleKontaktPerson" und "verbrauchsstelleObjektStrasse". Wieso nicht? :-(
Option Explicit
Public Sub Werte_eintragen()
Application.ScreenUpdating = False
Dim wsSource As Worksheet
Dim wsDestination As Worksheet
Dim rZelle As Range, rZiel As Range
Dim aUeberschr As Variant
Dim iIndx As Integer
Dim lZeile As Long
Dim i As Integer
Dim AnzahlZeilen As Integer
Dim A As Long
aUeberschr = Array("zählerNummer", "zählpunktNummer", "geraeteartText", "herstellerText", _
"brennerartText", "geraetetypbezeichnung", "verbrauchsstelleAnwohner", _
"verbrauchsstelleAnschriftStrasse", "verbrauchsstelleAnschriftHausnummer", _
"verbrauchsstelleAnschriftPlz", "verbrauchsstelleAnschriftOrt", _
"verbrauchsstelleKontaktPerson", "verbrauchsstelleObjektStrasse", _
"verbrauchsstelleObjektHausnummer", "verbrauchsstelleObjektOrt", "status")
'Das sind die zu prüfenden Spaltenüberschriften
Set wsSource = Worksheets("Quelltabelle") 'das Quell-Tabellenblatt
Set wsDestination = Worksheets("Geräte") 'das Ziel-Tabellenblatt
wsDestination.Columns.Hidden = False
i = 4
Application.EnableEvents = False
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
A = wsSource.Rows(1).Find(aUeberschr(iIndx), LookAt:=xlWhole, _
LookIn:=xlValues).Column
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
AnzahlZeilen = wsSource.Cells(Rows.Count, A).End(xlUp).Row
'Gibt letzte beschriebene Zeile in Spalte "Spaltenüberschrift" aus
wsSource.Range(rZelle.Rows(2), rZelle.Rows(AnzahlZeilen)).Copy
'rZelle soll die Spalte mit gefundene Überschrift aus "Quelltabelle"
'ab Zeile 2 bis zum letzten Wert in dieser Spalte kopieren
lZeile = wsDestination.Cells(Rows.Count, i).End(xlUp).Row + 1
'Sucht erste leere Zeile ab Spalte i bzw. ab Spalte D
wsDestination.Range(Cells(lZeile, i), rZiel.End(xlDown)).PasteSpecial _
xlPasteValues
i = i + 1
End If
End If
Next iIndx 'Nimm nun die nächste Spaltenüberschrift
Application.Goto Reference:=Worksheets("NA-Geräte").Range("D1"), Scroll:=True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
Gruß,
Anne