VBA: Zeilen aus Range kopieren bei Übereinstimmung

Hallo zusammen
Ich möchte die Werte einer ganze Zeilen aus einem Bereich in einen zweiten Bereich auf ein anderes Blatt kopieren, sofern in einem zweiten einspaltigen Bereich die Werte in der gleichen Zeile übereinstimmen.
Range_Offset_Origin: Einspaltiger Bereich mit Vergelichswerten
Range_Offset_Target: Einspaltiger Bereich wo die Werte in der Zeile mit Offfset_Origin übereinstimmen müssen, damit die Werte der Zeile aus Range_Value_Origin nach Range_Value_Target kopiert werden.
Range_Value_Origin: Ursprungsbereich mit den zu kopierenden Werten
Range_Value_Target: Zielbereich, dieser kann auch mehr Zeilen umfassen als der Ursprungsbereich.
Dazu benötige ich VBA Code und ich tue mich extrem schwer damit. Einen ganzen Range zu kopieren schaffe ich noch. Für mich wäre ein effizientes Beispiel sehr hilfreich, da die Bereiche recht gross sind.
Anbei habe ich auf dem Blatt "Übersicht" nochmals illustriert, was Ausgangslage ist und als Ergebnis dastehen soll. Zwei entsprechende Testblätter namens "Origin" und "Target" sind auch enthalten.
https://www.herber.de/bbs/user/84119.xlsx
Ganz herzlichen Dank für eure Hilfe!
Liebe Grüsse
Patrik

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Function Resize_Range(OrigRange As Range, C_Offset As String) As Range Dim lft, spalten As Integer Dim rng As Range Set rng = OrigRange lft = Asc(C_Offset) - 64 spalten = rng.Columns.Count lft = rng.Column - lft Set rng = rng.Resize(, spalten + lft) Set rng = rng.Offset(, -1 * lft) Set Resize_Range = rng End Function Public Sub CopyIfRanges() Dim myTarget As Variant Dim myOrigin As Variant Dim myDic As Object Dim C As Integer Dim L As Long Dim LowerB As Long Dim UpperB As Long Dim CtoCopy As Long Dim C_Offset_Origin As String Dim C_Offset_Target As String Dim RNG_Value_Origin As Range Dim RNG_Value_Target As Range Set RNG_Value_Origin = Sheets("Origin").Range("RANGE_VALUE_ORIGIN") Set RNG_Value_Target = Sheets("Target").Range("RANGE_VALUE_TARGET") C_Offset_Origin = "A" C_Offset_Target = "B" myOrigin = Resize_Range(RNG_Value_Origin, C_Offset_Origin) myTarget = Resize_Range(RNG_Value_Target, C_Offset_Target) Set myDic = CreateObject("Scripting.Dictionary") LowerB = RNG_Value_Origin.Column CtoCopy = RNG_Value_Origin.Columns.Count UpperB = RNG_Value_Origin.Column + CtoCopy - 1 For L = LBound(myOrigin) To UBound(myOrigin) 'Unikate sammeln '""" MEIN PROBLEM """" For C = LowerB To UpperB myDic(myOrigin(L, 1)) = myOrigin(L, C) 'Das Funktioniert nicht ' myDic(myOrigin(L, 1)) = Array(myOrigin(L, 5), myOrigin(L, 6)) Next '""" Mein Problem """" Next For L = LBound(myTarget) To UBound(myTarget) If myDic.exists(myTarget(L, 1)) Then 'Prüfung ob wert aus Offset_Target in _ Offset_Origin vorhanden For C = 0 To CtoCopy - 1 myTarget(L, C + RNG_Value_Target.Column) = myDic(myTarget(L, 1))(C) 'Wenn ja _ Werte übertragen Next End If Next Sheets("Target").Range("B5:G14") = myTarget 'Alles wieder zurückschreiben End Sub

Hallo zusammen
Nachfolgend die von mir verwendete finale Version. Diese basiert auf der von Ransi vorgeschlagenen, es werden aber nur die Werte aus dem Bereich Range_Value_Origin überschreiben, die restlichen Bereiche (und insbesondere Formeln) werden nicht tangiert. Vielleicht hilft dies ja jemandem.

Option Explicit
Function Resize_Range(OrigRange As Range, C_Offset As String) As Range
Dim lft, spalten As Integer
Dim rng As Range
Set rng = OrigRange
lft = Asc(C_Offset) - 64
spalten = rng.Columns.Count
lft = rng.Column - lft
Set rng = rng.Resize(, spalten + lft)
Set rng = rng.Offset(, -1 * lft)
'MsgBox rng.Address
Set Resize_Range = rng
End Function
Public Sub CopyIfRanges()
Dim myTarget As Variant         ' Gesamten Bereich Offset - Zielbereich
Dim myOrigin As Variant         ' Gesamte Bereich Offset - Ursprungsbereich
Dim myTarget_Area As Variant    ' Array mit Grösse des ursprünglichen Zielbereichs
Dim myDic As Object             ' Fungiert als Sortier-Hilfe für die korrekte Wertzuordnung
Dim C As Long                   ' Zählt die Columns durch
Dim L As Long                   ' Zählt die Linien/Rows durch
Dim LowerB As Long              ' Untere Grenze im Ziel-Array, damit Position der Werte  _
stimmt
Dim UpperB As Long              ' Obere Grenze
Dim CtoCopy As Long             ' Colums to Copy - Anzahl Spalten im Urpsrungsbereich
Dim Arr_Zeile As Variant        ' Übernahme der ganzen Zeile des Ursprungsbereichs
'Dim Target_Start  As Long      ' Zielspalte im Array; Nur für ALLE WERTE inkl. Offset
'Dim rng_Resize_Target As Range ' Transformierten Target-Range: Nur für ALLE WERTE
Dim C_Offset_Origin As String   ' Vergleichsspalte im Ursprungsblatt;  ersetzen
Dim C_Offset_Target As String   ' Vergleichsspalte im Zielblatt; ersetzen
Dim RNG_Value_Origin As Range   ' Range mit Werten des zu kopierenden Bereichs; ersetzen
Dim RNG_Value_Target As Range   ' Range wo Werte hinkopiert werden müssen; ersetzen
'Fürs Testing, danach durch Variablen ersetzen
Set RNG_Value_Origin = Sheets("Origin").Range("RANGE_VALUE_ORIGIN")
Set RNG_Value_Target = Sheets("Target_S").Range("RANGE_VALUE_TARGET")
C_Offset_Origin = "A"
C_Offset_Target = "C"
'Resize des Ursprungsbereichs auf durchgenhenden Bereich inkl. des Offsets
myOrigin = Resize_Range(RNG_Value_Origin, C_Offset_Origin)
' für ganzen Bereich zwischen Offset & Value die nächsten zwei Zeile aktivieren
' Set rng_Resize_Target = Resize_Range(RNG_Value_Target, C_Offset_Target)
' myTarget = rng_Resize_Target
myTarget = Resize_Range(RNG_Value_Target, C_Offset_Target) oberhalb ersetzen
myTarget_Area = RNG_Value_Target
Set myDic = CreateObject("Scripting.Dictionary")
LowerB = RNG_Value_Origin.Column
CtoCopy = RNG_Value_Origin.Columns.Count
UpperB = RNG_Value_Origin.Column + CtoCopy - 1
'Target_Start = RNG_Value_Target.Column - Asc(C_Offset_Target) + 65
For L = LBound(myOrigin) To UBound(myOrigin) 'Unikate sammeln
ReDim Arr_Zeile(0)
For C = LowerB To UpperB
'dem zuletzt hizugefügten Array-Feld einen Wert zuweisen
Arr_Zeile(UBound(Arr_Zeile)) = myOrigin(L, C)
'alte Datenfelder behalten und ein neues Array-Feld hinzufügen
ReDim Preserve Arr_Zeile(UBound(Arr_Zeile) + 1)
Next
myDic(myOrigin(L, 1)) = Arr_Zeile
' Array löschen
Erase Arr_Zeile
Next
For L = LBound(myTarget) To UBound(myTarget)
If myDic.exists(myTarget(L, 1)) Then 'Prüfung ob Werte übereinstimmen
For C = 0 To CtoCopy - 1
'myTarget(L, C + Target_Start) = myDic(myTarget(L, 1))(C) 'überträgt ganzen  _
Bereich
myTarget_Area(L, C + 1) = myDic(myTarget(L, 1))(C) 'Werte auf Zielbereich ü _
bertragen
Next
End If
Next
'Sheets("Target_S").Range(rng_Resize_Target.Address) = myTarget 'Ganzen Bereich inkl.  _
Offset
Sheets("Target_S").Range(RNG_Value_Target.Address) = myTarget_Area ' Nur Werte aus  _
Origin_Value
End Sub

Beliebteste Forumthreads (12 Monate)

VBA: Zeilen aus Range kopieren bei Übereinstimmung

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

342 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA: Zeilen aus Range kopieren bei Übereinstimmung

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

342 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread