vba Code vergleicht zwei Zellen lange Laufzeit
30.06.2016 14:05:58
Daum
ich habe folgendes Problem habe mir einen Code zusammengebastelt welcher die Zellen der Spalte B aus einer Tabelle mit den Zellen aus Spalte B einer anderen Tabelle (Materialstammliste) vergleicht und wenn es einen Treffer gibt soll es aus der Tabelle Materialstammliste die dazugehörigen Werte in Tabelle 1 kopieren.
So weit so gut es Funktioniert auch tadellos allerdings läuft er nach dem er die letzten daten kopiert hat noch sehr lange weiter.
Theoretisch müsste er aufhören sobald in Tabelle 1 der letzte Wert verglichen und kopiert worden ist.
Hier der Code:
Sub Artikel_aus_Materialstammliste_übernehmen()
'Materialstammliste öffnen
Workbooks.Open Filename:="T:\Materialstammliste.xls"
'Variable als Ganzzahlig definiert
Dim i As Integer
Dim i2 As Integer
'i von 5 bis (Benutze Felder zählen)
For i = 5 To Workbooks(1).Worksheets("deutsch").UsedRange.Rows.Count
For i2 = 6 To Workbooks("Materialstammliste").Worksheets("Artikelnummern").UsedRange.Rows.Count
'Vergleich der Spalte B von SL mit Mat.stammliste
If Workbooks(1).Worksheets("deutsch").Range("B" & i) = Workbooks("Materialstammliste"). _
Worksheets("Artikelnummern").Range("B" & i2) Then
'Wenn Zelle Leer mache nichts
If Workbooks(1).Worksheets("deutsch").Range("B" & i) = "" Then
i = i
'Wenn Zelle Voll kopiere in SL
Else
Workbooks("Materialstammliste").Worksheets("Artikelnummern").Range("C" & i2). _
Select
Selection.Copy
Workbooks(1).Worksheets("deutsch").Range("C" & i).PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=False
Workbooks("Materialstammliste").Worksheets("Artikelnummern").Range("E" & i2, "L" _
& i2).Select
Selection.Copy
Workbooks(1).Worksheets("deutsch").Range("E" & i, "L" & i).PasteSpecial
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks :=False, Transpose:=False
End If
End If
Next i2
Next i
End Sub
Vielen Dank schonmal im Voraus.
Gruß Daum