Werte suchen und in Zielmappe kopieren
11.03.2021 19:30:46
Gerald
Ich arbeite mit 2 Arbeitsmappen.
Die 1. Mappe ist für die Sammlung der Daten aus der anderen 2. Mappe zuständig.
Mappe1 (Zielmappe)
Hier stehen in Spalte A ab Zeile 3 untereinander ID-Nummern (Anzahl ist unterschiedlich).
In Zeile 2 stehen in den Spalten C, D, E, F, G, H, I . Überschriften der zu suchenden Daten
Anhand der IDs in Spalte A soll nun in Mappe2 (Quellmappe) die richtige Zeile und Spalte gesucht werden um die benötigten Daten in die Zielmappe zu kopieren.
Das Problem ist, das in der Mappe2 (Quelle) die Daten auf verschiedenen Tabellenblättern stehen.
Ich habe mit Hilfe eines Codes zwar einen Weg gefunden, aber es dauert irre lange bis er alle Werte kopiert hat.
Wenn man beobachtet wie die Zellen in der Mappe1 gefüllt werden denkt man es läuft in Zeitlupe ab.
Und wenn er dann aus dem Sheet(2) in der Mappe2 Daten suchen will, dauert es fast 2 Minuten bis er damit anfängt.
Ich habe das Gefühl, das der Code die gesamte Spalte A in der Zielmappe abarbeitet und nicht nur die gefüllten Zellen in A mit IDs
Vielleicht hat ja jemand eine bessere Lösung für mich.
Ich hätte gern Beispieldateien beigefügt, aber es sind alles sehr sensible SAP Daten aus meiner Firma.
Hier mal mein Code:
Public Sub Werte_kopieren_aus_Quelle()
'Mit diesem Makro werden die Werte, abhängig von der eingetragenen ID in der Zielmappe (Spalte _
A),
'in der Quellmappe ermittelt und kopiert
'Quellmappe -> Sheet 1
Dim lngRow As Long
Dim objCell As Range
Dim objTargetSheet As Worksheet, objSourceSheet As Worksheet
Set objTargetSheet = ThisWorkbook.Sheets(1) 'Die Zielmappe, Blatt _
Berechnung
Set objSourceSheet = Workbooks("Quellmappe.xlsx").Sheets(1) 'Die Quellmappe _
KPI und dort das Blatt 1
With objTargetSheet
For lngRow = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row 'Fange ab Zeile 3 in _
Spalte A an die IDs einzulesen (Zielmappe)
'Suche in Quellmappe in _
Spalte A diese IDs
Set objCell = objSourceSheet.Columns(1).Find( _
What:=.Cells(lngRow, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not objCell Is Nothing Then
.Cells(lngRow, 3).Value = objCell.Offset(0, 1).Value 'Trage in der Zielmappe _
in Spalte 3 (entspricht Spalte C)
'den Wert aus der _
Quellmappe aus Spalte B ein
'Offset(0, 1) steht für _
1 Spalte in der Mappe nach rechts = B
'Offset(0, 4) würde heiß _
en 4 Spalten nach rechts = E
.Cells(lngRow, 4).Value = objCell.Offset(0, 2).Value
.Cells(lngRow, 5).Value = objCell.Offset(0, 3).Value
.Cells(lngRow, 6).Value = objCell.Offset(0, 4).Value
.Cells(lngRow, 7).Value = objCell.Offset(0, 6).Value
Set objCell = Nothing
End If
Next
End With
Set objTargetSheet = Nothing
Set objSourceSheet = Nothing
'Quellmappe -> Sheet 2
Set objTargetSheet = ThisWorkbook.Sheets(1)
Set objSourceSheet = Workbooks("Quellmappe.xlsx").Sheets(2)
With objTargetSheet
For lngRow = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
Set objCell = objSourceSheet.Columns(1).Find( _
What:=.Cells(lngRow, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not objCell Is Nothing Then
.Cells(lngRow, 8).Value = objCell.Offset(0, 3).Value
.Cells(lngRow, 9).Value = objCell.Offset(0, 4).Value
Set objCell = Nothing
End If
Next
End With
Set objTargetSheet = Nothing
Set objSourceSheet = Nothing
'Quellmappe -> Sheet 3
Set objTargetSheet = ThisWorkbook.Sheets(1)
Set objSourceSheet = Workbooks("Quellmappe.xlsx").Sheets(3)
With objTargetSheet
For lngRow = 3 To .Cells(.Rows.Count, 1).End(xlUp).Row
Set objCell = objSourceSheet.Columns(1).Find( _
What:=.Cells(lngRow, 1).Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not objCell Is Nothing Then
.Cells(lngRow, 10).Value = objCell.Offset(0, 2).Value
.Cells(lngRow, 11).Value = objCell.Offset(0, 3).Value
Set objCell = Nothing
End If
Next
End With
Set objTargetSheet = Nothing
Set objSourceSheet = Nothing
End Sub