AW: VBA: Zeilen aus Range kopieren bei Übereinstimmung
02.03.2013 00:36:36
Patrik
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