VBA Wert suchen - dann anderen Wert einfügen

Hallo Liebe Gemeinde,
ich habe mal wieder ein Problem, das ich gerne über einen VBA lösen möchte, da diese Formel die meiste Zeit an Berechnung in Anspruch nimmt.
Ich habe zwar eine Lösung per WENN-Formel, allerdings dauert die Berechnung ewig, da die Excel tausende von Zeilen hat und es bereits schon viele Formeln zu berechnen gibt.
Der VBA-Code sollte folgendes lösen:
Es soll geprüft werden, ob die Zahl in "Spalte C" in der "Spalte A" vorkommt. Wenn das so ist, dann soll in der "Spalte E" in jeder Zeile wo die Zahl aus "Spalte C" in der "Spalte A" vorkommt eine 1 eingetragen werden. Danach soll geprüft werden, ob die Zahl in "Spalte D" in der "Spalte A" vorkommmt. Erneut soll dann in der "Spalte E" in jeder Zeile wo die Zahl aus "Spalte D" in der "Spalte A" vorkommt eine 2 eintragen. Wenn die Zahl aus "Spalte A" weder in der "Spalte C" oder "Spalte D" vorkommt, dann soll überall eine 3 stehen.
Wäre super wenn Ihr mir helfen könnt. Anbei ein Muster:
https://www.herber.de/bbs/user/91506.xlsx

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub zahlenspalte() Dim wks As Worksheet Set wks = ActiveWorkbook.ActiveSheet Dim x As Long, y As Long x = wks.Cells(Rows.Count, 2).End(xlUp).Row Application.ScreenUpdating = False With wks For y = 3 To x If Application.CountIf(.Columns(3), .Cells(y, 1)) > 0 Then wks.Cells(y, 5) = 1 ElseIf Application.CountIf(.Columns(4), .Cells(y, 1)) > 0 Then wks.Cells(y, 5) = 2 ElseIf Application.CountIf(.Columns(3), .Cells(y, 1)) = 0 And Application.CountIf(.Columns(4), _ .Cells(y, 1)) = 0 Then wks.Cells(y, 5) = 3 End If Next y End With Application.ScreenUpdating = True End Sub

Sub Pruefung() Dim lRow As Long, l As Long With ThisWorkbook.Worksheets("Tabelle1") With .Range(.Cells(3, 5), .Cells(.Rows.Count, 2).End(xlUp).Offset(0, 3)) .Formula = "=3-IFERROR((MATCH(A3,D:D,0)>0)*1,0)-IFERROR((MATCH(A3,C:C,0)>0)*2,0)" .Value = .Value End With End With End Sub

Sub Pruefung() With Application .Calculation = xlCalculationManual .EnableEvents = False .ScreenUpdating = False End With With ThisWorkbook.Worksheets("Tabelle1") With .Range(.Cells(3, 5), .Cells(.Rows.Count, 2).End(xlUp).Offset(0, 3)) .Formula = "=3-IFERROR((MATCH(A3,D:D,0)>0)*1,0)-IFERROR((MATCH(A3,C:C,0)>0)*2,0)" .Calculate .Value = .Value End With End With With Application .Calculation = xlCalculationAutomatic .EnableEvents = True .ScreenUpdating = True End With End Sub

Hi
ich tippe mal auf grosse Datenmengen, dann ist Match mit 3. Parameter = 0 recht langsam, vorallem wenn es wenig fundstellen gibt und dann immer die ganze Spalte durchsucht werden muss.
ich würde ihr erstmal die Spalten C und D an eine freie Stelle der Tabelle kopieren, um sie dort zu sortieren und dann die Prüfung mit der schnellen Variante des SVerweises durchführen (4. Parameter = 1)
(man könnte zwar auch in der Tabelle sortieren, aber ich vermute, das ist nicht erwünscht):
ich kopiere hier die Werte in die Spalten AA und AB (27 und 28), die sollten frei sein, falls nicht, hierfür im Code andere Spalten verwenden (Anpassung bei den Formeln nicht vergessen)

Sub Test()
Dim letzteZeile As Long
letzteZeile = Cells(Rows.Count, 1).End(xlUp).Row
Range("C3:D" & letzteZeile).Copy
Cells(2, 27).PasteSpecial xlPasteValues
Cells(1, 27) = WorksheetFunction.Min(Range("A3:A" & letzteZeile)) - 1
Cells(1, 28) = Cells(1, 27)
Columns(27).Sort key1:=Cells(1, 27), order1:=xlAscending, Header:=xlNo
Columns(28).Sort key1:=Cells(1, 28), order1:=xlAscending, Header:=xlNo
With Range("E3:E" & letzteZeile)
.FormulaR1C1 = "=3-2*(VLookUp(RC1,C27,1,1)=RC1)-1*(VLookUp(RC1,C28,1,1)=RC1)"
.Formula = .Value
End With
Columns(27).Resize(, 2).ClearContents
End Sub

Gruß Daniel

Beliebteste Forumthreads (12 Monate)

VBA Wert suchen - dann anderen Wert einfügen

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

326 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA Wert suchen - dann anderen Wert einfügen

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

326 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread