Makro zum vergleichen und verschieben von Werten
17.04.2015 22:07:06
Werten
ich bin neu hier, also verzeiht mir bitte eventuelle Fehler...
Ich bin auf der Suche nach einem Makro mit dem ich die eingetragenen Werte in dem Tabellenblatt1 Spalte B mit allen Werten in den Tabellenblättern2 & 3 vergleichen kann. Hierbei gibt es schon das erste Problem die werte müssen zwei Bedingungen erfüllen. In der Spalte A muss z.Bsp. "S2" stehen und in der Spalte C muss "i.o" stehen. Erst wenn diesebeiden Bedingungen erfüllt sind darf der Wert verglichen werden. Wenn es keine Übereinstimmung gibt, soll der Wert in das Tabellenblatt4 Zelle B6 kopiert werden. Ich benötige das Makro um die Formel die ich bisher verwende abzulösen, da diese meine Liste extrem langsam macht. Hier mal die Formel damit ihr versteht wie das Makro arbeiten soll
{=WENNFEHLER(INDEX(Prüfliste!$B:$B;MIN(WENN(ISTNV(VERGLEICH(Prüfliste!$B$3:$B$3991; Ausgeliefert!$D$1:$D$4000;))*ISTNV(VERGLEICH(Prüfliste!$B$3:$B$3991;Auslieferung!$E$6:$E$43;)) *ISTNV(VERGLEICH(Prüfliste!$B$3:$B$3991;$E$5:$E7;))*(Prüfliste!$C$3:$C$3991="i.o") *(Prüfliste!$A$3:$A$3991="S5");ZEILE(Prüfliste!$3:$3991))));"") } diese Formel steht z.Bsp. in E8. Im Moment steht diese Formel in jeder Zelle in dem Bereich von B6 bis E21, natürlich entsprechend der Bedingungen leicht abgewandelt. Und darum könnt ihr euch sicher vorstellen warum ich auf ein Makro zurückgreifen möchte. :)
Soweit bin ich schon gekommen:
Sub Kopieren()
Dim rng As Range
For Each rng In Sheets("Prüfliste").Range("B3:B" & Range("B65536").End(xlUp).Row)
If Sheets("Auslieferung").Range("G3") >= 1 Then
End If
Sheets("Auslieferung").Range("A6") = "Satz 1"
If Sheets("Prüfliste").Cells(rng.Row, 2) Sheets("Ausgeliefert").Cells(Rows.Count, 1) And _
_
Sheets("Prüfliste").Cells(rng.Row, 1) = "S2" And _
Sheets("Prüfliste").Cells(rng.Row, 3) = "i.o" Then
Sheets("Prüfliste").Cells(rng.Row, 2).Copy _
Destination:=Sheets("Auslieferung").Cells(6, 2)
End If
Next rng
For Each rng In Sheets("Prüfliste").Range("B3:B" & Range("B65536").End(xlUp).Row)
If Sheets("Prüfliste").Cells(rng.Row, 2) Sheets("Ausgeliefert").Cells(Rows.Count, 2) And _
Sheets("Prüfliste").Cells(rng.Row, 1) = "S3" And _
Sheets("Prüfliste").Cells(rng.Row, 3) = "i.o" Then
Sheets("Prüfliste").Cells(rng.Row, 2).Copy _
Destination:=Sheets("Auslieferung").Cells(6, 3)
End If
Next rng
For Each rng In Sheets("Prüfliste").Range("B3:B" & Range("B65536").End(xlUp).Row)
If Sheets("Prüfliste").Cells(rng.Row, 2) Sheets("Ausgeliefert").Cells(Rows.Count, 3).End( _
xlUp).Row And _
Sheets("Prüfliste").Cells(rng.Row, 1) = "S4" And _
Sheets("Prüfliste").Cells(rng.Row, 3) = "i.o" Then
Sheets("Prüfliste").Cells(rng.Row, 2).Copy _
Destination:=Sheets("Auslieferung").Cells(6, 4)
End If
Next rng
For Each rng In Sheets("Prüfliste").Range("B3:B" & Range("B65536").End(xlUp).Row)
If Sheets("Prüfliste").Cells(rng.Row, 2) Sheets("Ausgeliefert").Cells(Rows.Count, 4). _
End(xlUp).Row And _
Sheets("Prüfliste").Cells(rng.Row, 1) = "S5" And _
Sheets("Prüfliste").Cells(rng.Row, 3) = "i.o" Then
Sheets("Prüfliste").Cells(rng.Row, 2).Copy _
Destination:=Sheets("Auslieferung").Cells(6, 5)
End If
Next rng
End Sub
allerings bezieht dieses Makro nicht alle Vergleichswerte mit ein und bekomme ich auch Nummern die schon vergeben sind raus.
Vielen Dank im voraus!!!