Zellen variabel kopieren

Hallo Excel Freunde,
ich möchte aus einem Arbeitsblatt (Eingabe) die Werte aus SpalteB kopieren und in einem zweiten Arbeitsblatt (gespeicherte Daten) in einer über eine Variable gesteuerten Zeile einfügen.
Das Problem ist das es in der SpalteB leere Zellen zwischendrin gibt und im Arbeitsblatt2 in der Zeile soll das nicht vorkommen. Bei diesen leeren Zellen soll nichts passieren.
Der zu kopierenden SpalteB ist eine SpalteA mit Benennungen vorgesetzt die auch in Arbeitsblatt2 vorhanden ist, jedoch dort als 1. Zeile.
Ich habe in eine For Schleife die über der Benennungsspalte im Arbeitsblatt1 läuft geschrieben. Wenn in einer Zelle ein Wert steht überträgt er den Parameter der nächsten Spalte (gleicher Zeile) in eine Variable.
Soweit so gut!
Beim Einfügen dieser Variablen in das Arbeitsblatt2 komme ich nicht weiter. Nachdem eine leere Zelle in Arbeitsblatt1 durchlaufen ist werden alle weiteren Werte nicht mehr in die richtige Zelle kopiert.
Meine Datei: https://www.herber.de/bbs/user/149400.xlsm.

Über Hilfestellungen würde ich mich sehr freuen.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Daten_kopieren() Dim Dict Dim Z Dim ZielZeile As Integer 'für Dictionary, siehe https://excelmacromastery.com/vba-dictionary/ Set Dict = CreateObject("Scripting.Dictionary") 'alle Überschriften und Wert in Quelle sammeln With Worksheets("Eingabe") For Each Z In .Range(.Range("A1"), .Range("A999").End(xlUp)).Cells If Z.Offset(0, 1) "" Then Dict.Add Z.Value, Z.Offset(0, 1).Value Next End With ZielZeile = ThisWorkbook.Worksheets("Eingabe").Cells(1, 7).Value 'mit dem Ziel-Überschrift als Schlüssel, Wert aus der Sammlung holen und ablegen With Worksheets("gespeicherte Daten") For Each Z In .Range("B1:G1").Cells If Dict.exists(Z.Value) Then .Cells(ZielZeile, Z.Column) = Dict(Z.Value) Next End With Set Dict = Nothing End Sub

Sub Daten_kopieren3() Dim ID As Double Dim ParamE As Variant Dim varResult Dim n As Integer Dim i As Long ID = ThisWorkbook.Worksheets("Eingabe").Cells(1, 7).Value For n = 2 To 20 ParamE = Worksheets("Eingabe").Cells(n, 1).Value If ParamE "" Then With Worksheets("gespeicherte Daten").ListObjects(1) varResult = Application.WorksheetFunction.Match(ParamE, .HeaderRowRange, 0) If IsNumeric(varResult) Then .ListRows(ID).Range.Cells(1, varResult).Value = Worksheets("Eingabe").Cells(n, 2).Value End If End With End If Next n End Sub

Sub Daten_kopieren3() Dim ID As Double Dim ParamE As Variant Dim varResult Dim n As Integer Dim i As Long Dim myNewColumn As ListColumn ID = ThisWorkbook.Worksheets("Eingabe").Cells(1, 7).Value For n = 2 To 20 ParamE = Worksheets("Eingabe").Cells(n, 1).Value If ParamE "" Then With Worksheets("gespeicherte Daten").ListObjects(1) Do i = i + 1 varResult = Application.Match(ParamE, .HeaderRowRange, 0) If IsNumeric(varResult) Then .ListRows(ID).Range.Cells(1, varResult).Value = Worksheets("Eingabe").Cells(n, 2).Value i = 2 Else Set myNewColumn = .ListColumns.Add myNewColumn.Name = ParamE Set myNewColumn = Nothing End If Loop Until i = 2 End With End If Next n End Sub

Hallo zusammen,
wenn Ralf eine angepasste Version liefert, möchte nicht hinterher sein ;-)
Anbei eine leicht geänderte Variante meiner Zuordnung über Dictionary.
Nur der Umfang des zweiten For muss einmalig angepasst werden.
Es wird angenommen, dass der Überschrift im Zieltabelle ab B1 anfängt, mindestens 2 Überschriften hat (also mind. C1 befüllt) und dass nach dem letzten Überschrift eine leere Zelle liegt (z.B.) in J1. Dann kann man mit .End(XlToLeft) ab B1 arbeiten, um allen Überschriften, heute, morgen, übermorgen abzugfangen.


Sub Daten_kopieren()
Dim Dict
Dim Z
Dim ZielZeile As Integer
'für Dictionary, siehe https://excelmacromastery.com/vba-dictionary/
Set Dict = CreateObject("Scripting.Dictionary")
'alle Überschriften und Wert in Quelle sammeln
With Worksheets("Eingabe")
For Each Z In .Range(.Range("A1"), .Range("A9999").End(xlUp)).Cells
If Z.Offset(0, 1)  "" Then Dict.Add Z.Value, Z.Offset(0, 1).Value
Next
End With
ZielZeile = ThisWorkbook.Worksheets("Eingabe").Cells(1, 7).Value
'mit dem Ziel-Überschrift als Schlüssel, Wert aus der Sammlung holen und ablegen
With Worksheets("gespeicherte Daten")
For Each Z In .Range(.Range("B1"), .Range("B1").End(xlToRight)).Cells
If Dict.exists(Z.Value) Then .Cells(ZielZeile, Z.Column) = Dict(Z.Value)
Next
End With
Set Dict = Nothing
End Sub

Erratum:
in meinem letzten Post war "Geliefert wie bestellt" zu lesen. Der Smartphone -doch nicht so smart- korrigiert eigenwillig.
VG
Yal

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread