Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA: Zeilen aus Range kopieren bei Übereinstimmung

VBA: Zeilen aus Range kopieren bei Übereinstimmung
01.03.2013 10:05:19
Patrik
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

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

Betreff
Datum
Anwender
Anzeige
AW: VBA: Zeilen aus Range kopieren bei Übereinstimmung
01.03.2013 10:27:31
ransi
Hallo Patrick
Ich würds so machen:
Option Explicit


Public Sub machs()
    Dim myTarget As Variant
    Dim myOrigin As Variant
    Dim myDic As Object
    Dim L As Long
    myTarget = Sheets("Target").Range("B5:G14") 'Anpassen
    myOrigin = Sheets("Origin").Range("A3:F9") 'Anpassen
    Set myDic = CreateObject("Scripting.Dictionary")
    For L = LBound(myOrigin) To UBound(myOrigin) 'Unikate sammeln
        myDic(myOrigin(L, 1)) = Array(myOrigin(L, 5), myOrigin(L, 6)) 'Zu jedem Unikat die passenden Werte aus Value_Origin aufnehmen
    Next
    For L = LBound(myTarget) To UBound(myTarget)
        If myDic.exists(myTarget(L, 1)) Then 'Prüfung ob wert aus Offset_Target in Ofrfset_Origin vorhanden
            myTarget(L, 4) = myDic(myTarget(L, 1))(0) 'Wenn ja Werte übertragen
            myTarget(L, 5) = myDic(myTarget(L, 1))(1)
        End If
    Next
    Sheets("Target").Range("B5:G14") = myTarget 'Alles wieder zurückschreiben
End Sub


Hat den Vorteil das das auch bei großen Datenmengen sauschnell ist.
ransi

Anzeige
AW: VBA: Zeilen aus Range kopieren bei Übereinstimmung
01.03.2013 11:02:09
Patrik
Hallo Ransi
Ganz herzlichen Dank, das ging ja extrem schnell. Damit kann ich was anfangen, ist ein interessanter Ansatz!
Die Problemstellung bei mir ist jetzt nur noch, dass dies in einem komplexen Sheet x-Mal gemacht werden muss und der Range_Value_Origin in der Anzahl Spalten variert - also 2 - 20 Spalten umfassen kann. Lässt sich das ganze in eine Funktion packen mit den 4 Ranges als Übergansparameter und myTarget als Return-Wert? Wäre natürlich toll, wenn das dann für Bereiche beleibiger Breite funktionieren würde, also im Stil

Function SelectRangeCopy(Range_Offset_Origin, Range_Offset_Target, Range_Value_Origin, Range_Value_Target As Range) As Variant

Anzeige
AW: VBA: Zeilen aus Range kopieren bei Übereinstimmung
01.03.2013 19:30:11
Patrik
Brauche nochmals hilfe. Habe das verallgemeinert, aber in der Array Verknüpfung von myDic stehe ich auf dem Schlauch. Wie erweitere ich den MyDic Array, wenn ich die Anzahl Spalten flexibel gestalten will? Ich habe unten den Bereich mit '### Mein Problem gekennzeichnet
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

Anzeige
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

Anzeige
=sverweis() ?
02.03.2013 09:45:06
ransi
Hallo Patrick
Dazu benötige ich VBA Code...
Ich hab da nochmal drüber geschlafen.
Normalerweise reicht für dein Vorhaben doch ein ganz normaler =Sverweis() ?
ransi

AW: =sverweis() ?
02.03.2013 10:39:07
Patrik
Hi Ransi
Du hast vollkommen recht - wenn es innerhalb der gleichen Arbeitsmappe wäre :-) Ich habe die Aufgabenstellung etwas vereinfacht, weil es mir ums Prinzip ging. Ich möchte eingetrage Werte aus der einen Excel-Datei in eine neue Datei, welche mehr Funktionen umfasst, übbertragen. Entsprecehnd stehen die Daten ungefähr am gleichen Ort, es können aber neue Zeilen hinzugekommen sein. Zudem geht es um ca. 150 untershciedliche Bereiche, die übertragen werden. Die Angaben mit den Bezeichnungen zum Blatt und dem zu übertragenen Bereich sind für all die verschiedenen Versionene in einem Const Blatt erfasst. Deshalb benötige ich VBA-Code - um diese automatisiert von der alten Datei in die neue Vorlage zu kopieren. Das Dateihandling habe ich bereits gelöst, weshalb ich das ausklammern wollte, ebenso schaffe ich es, normale Ranges zu kopieren. Falls du mehr wissen möchtest, kann ich dir den Link auf die vollständige Datei senden.
Gruss Patrik
Anzeige

364 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige