Excel VBA VLookup

[26865]

Letzter Versuch meinerseits:

Code:

Option Explicit
Sub Kanten_abziehen()

'Kanten abziehne wenn die Kante stärker als das "Max_Fügemaß" ist oder Platte oder Belag nicht gefügt werden kann
   
Dim LA As Long
Dim vRetP As Variant
Dim vRetBI As Variant
Dim vRetBA As Variant
Dim Abzugsmaß As Long
   
   
With Worksheets("Zwischenablage")
   For LA = .Cells(Rows.Count, 5).End(xlUp).Row To 1 Step -1
     
      If Not IsEmpty(.Cells(LA, 3).Value) Then vRetP = Application.IfError(Application.VLookup(.Cells(LA, 3).Value, Range("Lager"), 11, False), "Fehlendes Material")
      If Not IsEmpty(.Cells(LA, 9).Value) Then vRetBI = Application.IfError(Application.VLookup(.Cells(LA, 9).Value, Range("Lager"), 11, False), "Fehlendes Material")
      If Not IsEmpty(.Cells(LA, 8).Value) Then vRetBA = Application.IfError(Application.VLookup(.Cells(LA, 8).Value, Range("Lager"), 11, False), "Fehlendes Material")
   
       If Left(.Cells(LA, 12).Value, 3) = "KA_" Then
         Abzugsmaß = CLng(Mid(.Cells(LA, 12), InStrRev(.Cells(LA, 12), "X") + 1))
         If Abzugsmaß > Range("Max_Fügemaß").Value Or vRetP <> "x" Or vRetBI <> "x" Or vRetBA <> "x" Then
           .Cells(LA, 19).Value = .Cells(LA, 18).Value - Abzugsmaß
         End If
       End If
   
   Next LA
End With
     

End Sub

[snb]

Vermeide Worksheetfunctions in VBA

Code:

Sub M_snb()
  sn = Tabelle29.Cells(1).CurrentRegion
  sp = Tabelle2.Cells(1).CurrentRegion
  y = Range("Max_Fügemaß").Value
 
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sp)
      .Item(sp(j, 1)) = sp(11)
    Next
     
    For j = 1 To UBound(sn)
      If Left(sn(j, 12), 3) = "KA_" Then
        sq = Split(sn(j, 12), "_")
        If Val(sq(UBound(sq))) > y Or .Item(sn(j, 3)) <> "x" Or .Item(sn(j, 8)) <> "x" Or .Item(sn(j, 9)) <> "x" Then sn(j, 19) = sn(j, 18) - Val(sq(UBound(sq)))
      End If
    Next
  End With
End Sub

[legiminator]

Hallo snb,
vielen dank für deinen Vorschlag.
Ich habe es eingelesen und leider zeigt es mit einen fehler an

"Sub oder Funktion nicht definiert"

Wo leigt hier der Fehler?

---

Hallo Earlfred,
vielen Dank für ein letztes aufbäumen.

Code:

 For LA = .Cells(Rows.Count, 5).End(xlUp).Row To 1 Step -1

Leider ziegt es mir bei der Zeile einen Syntaxfehler an.
Ich habe die Zeile mit den Bestehenden verglichen. Habe dann gesehen das der "." zu viel ist. Wenn ich den lösche zeigt es mir die Meldung an "Fehler beim Kompelieren" "Erwartet: Anweisungsende"

Hier bin ich nicht weiter gekommen. Vermutlich ein Klax zum beheben. Ich selber komme leider hier nicht weiter.

---

Hallo EarlFred,
Danke für die Info zum Thema Hygiene. Ich selber kann die Schnippsel welche ich für diese Codes aus dem Internet zusammen suche leider schlecht bewerten. Da gehe ich doch zu leihenhaft vor. Aber solche Basics sind Gold wert.

Entschuldige meine "schwammigen Antworten" hier fehlt mir eure Denkweise. An und für sich sollte keine falsche Materialdefinfition rein kommen. Da die Überprüfung der Richtigen schreibweise nur über eine Bedingte Formatierung mit einfärben der Zelle funktionier ist also doch nichts unmöglich. 
Sollte sich keine Übereintreffung finden ist das kleiner Übel das hier nichts geschiet. Eine aufplopende Fehlermeldung wäre trozdem sehr brauchbar. Von dem Maß soll nichts abgezogen werden.


Ich danke dir für deine Gedult

---

Hallo Schauan,

nicht MsgBox vRetP = ... sondern nur MsgBox vRetP

ein Leichtsinsfehler

[26865]

Ich kann dir bestätigen, dass mein Code einwandfrei in der Mustermappe funktioniert. Der Punkt muss auch sein, um ordentlich zu referenzieren (Bezug zum With-Block).

Ich vermute also, dass der Code von Dir geändert wurde, was ich allerdings inhaltlich aus der Ferne schlecht bewerten kann.

[snb]

@Leg

Feedback sollte immer sinnvoll sein.
Verwende im VBEditor F8 und berichte in welcher Zeile der Fehler auftritt.

[legiminator]

Hallo Snb,
vielen Dank für die neue Fassung.

Zwei dinge sind mir aufgefallen:
- In der Spalte F wird ab Zeile 5 immer das Maß "X" abgezogen.
- Es wird nicht berücksichtigt ob das Material bei Fügen ein X hat. (Spalte 11, Lager)
- Es wird immer 23mm abgezogen. Hier wird aus dem Materialcodes aus den Spalten 10-13 vermutlich immer der Falsche Teil ausgeschnitten.

Code:

'Kanten abziehne wenn die Kante stärker als das "Max_Fügemaß" ist oder Platte oder Belag nicht gefügt werden kann

  sn = Worksheets("zwischenablage").Cells(1).CurrentRegion
  sp = Worksheets("Lager").Cells(1).CurrentRegion
  y = Range("Max_Fügemaß").Value '-> Entspricht aktuell "2"



  With CreateObject("scripting.dictionary")
    For jj = 2 To UBound(sp)
      If sp(jj, 11) <> "x" Then .Item(sp(jj, 1)) = sp(jj, 11)
    Next

    For jj = 1 To UBound(sn)
      If Left(sn(jj, 12), 3) = "KA_" Then
        sq = Split(sn(jj, 12), "_")
        If Val(sq(UBound(sq))) > y Or .exists(sn(jj, 3)) Or .exists(sn(jj, 8)) Or .exists(sn(jj, 9)) Then sn(jj, 5) = sn(jj, 5) - Val(sq(UBound(sq)))
      End If
    Next
  End With
 
 
 
 
    With CreateObject("scripting.dictionary")
    For jj = 2 To UBound(sp)
      If sp(jj, 11) <> "x" Then .Item(sp(jj, 1)) = sp(jj, 11)
    Next

    For jj = 1 To UBound(sn)
      If Left(sn(jj, 13), 3) = "KA_" Then
        sq = Split(sn(jj, 13), "_")
        If Val(sq(UBound(sq))) > y Or .exists(sn(jj, 3)) Or .exists(sn(jj, 8)) Or .exists(sn(jj, 9)) Then sn(jj, 5) = sn(jj, 5) - Val(sq(UBound(sq)))
      End If
    Next
  End With
 
 
 
 
    With CreateObject("scripting.dictionary")
    For jj = 2 To UBound(sp)
      If sp(jj, 11) <> "x" Then .Item(sp(jj, 1)) = sp(jj, 11)
    Next

    For jj = 1 To UBound(sn)
      If Left(sn(jj, 10), 3) = "KA_" Then
        sq = Split(sn(jj, 10), "_")
        If Val(sq(UBound(sq))) > y Or .exists(sn(jj, 3)) Or .exists(sn(jj, 8)) Or .exists(sn(jj, 9)) Then sn(jj, 6) = sn(jj, 6) - Val(sq(UBound(sq)))
      End If
    Next
  End With
 
 
 
 
    With CreateObject("scripting.dictionary")
    For jj = 2 To UBound(sp)
      If sp(jj, 11) <> "x" Then .Item(sp(jj, 1)) = sp(jj, 11)
    Next

    For jj = 1 To UBound(sn)
      If Left(sn(jj, 11), 3) = "KA_" Then
        sq = Split(sn(jj, 11), "_")
        If Val(sq(UBound(sq))) > y Or .exists(sn(jj, 3)) Or .exists(sn(jj, 8)) Or .exists(sn(jj, 9)) Then sn(jj, 6) = sn(jj, 6) - Val(sq(UBound(sq)))
      End If
    Next
  End With
 
  'Worksheets("zwischenablage").CurrentRegion = sn

Den Code habe ich mal entsprechend an meine Bereiche angepasst.

Beim abspielen wurde mir die letzte Zeile nicht genommen. Deswegen habe ich Sie mal ausgeschaltet
Die Bereiche in denen zum Ende hin immer das Maß abgezogen werden soll  konnte ich nicht ändern (19 anstatt 5 und 20 anstatt 6). Hier kommt dann die Fehlermeldung "Index außerhalb des gultigen Bereichs"

Der Code hat leider nichts in meiner Liste geändert. Das Muster habe ich aus der origignal Datei erstellt.

Ich bin ein wenig verweifelt

---

Hallo EarlFred,

anbei ein Screenshot wie es aussihet wenn ich es in die originale Datei oder auch in die Musterdatei einlese.

Code:

For LA = .Cells(Rows.Count, 5).End(xlUp).Row To 1 Step -1

Diese Zeile wird rot gefärbt und es kommt beim durchlaufen des Codes die Meldung Syntaxfehler.

Kann es an grundlegenden Einstellungen von Excel liegen?

[snb]

- Es wird nicht berücksichtigt ob das Material bei Fügen ein X hat. (Spalte 11, Lager)

Stimmt nicht; du hast den Code nicht verstanden.

- Es wird immer 23mm abgezogen. Hier wird aus dem Materialcodes aus den Spalten 10-13 vermutlich immer der Falsche Teil ausgeschnitten.

Verrate mal was abgezogen werden müsste.
Was ist das 'richtige' Teil ?

[legiminator]

Hallo snb,

Stimmt nicht; du hast den Code nicht verstanden.

Das mag ich jetzt nicht bestreiten. Das Resultat zeigt aber das hier das Maß nicht abgezogen wird. Wenn im Material das "X" Fehlt muss das Maß der Kante (Spalte 10-13) abgezogen werden.

(Wird das Material nicht gefunden soll nichts abgezogen werden)

Verrate mal was abgezogen werden müsste.

Was ist das 'richtige' Teil ?

Wenn eines der Materialien aus der Spalte 3,8 oder 9 das "x" hat soll das Maß des Kantenmaterials aus der Spalte (10-13) abgezogen werden.

Hier möchte ich jede Kante/Spalte einzeln abarbeiten.
Das Maße was abzuziehen ist, sind von rechts nach links die Ziffen bis zum ersten "x"  ("KA_W980_ST15_23X02" -> "02")
Diese 02mm sollen dann dementsprechend von dem Maß aus der Spalte 19 oder 20 abgezogen werden.


Ich hoffe du kannst damit was Anfange.
Vielen Dank schon mal für deine Hilfe!

[26865]

Eine Musterdatei wäre sinnvoller als das Bild.
Schreib die Zeile mal von Hand neu, vielleicht hat sich beim Kopieren ein Steuerzeichen versteckt.

[legiminator]

Hallo Zusamme,
jetzt hat es doch etwas gedauert bis ich zur Umsetztung gekommen bin.
Ich habe mich nochmals hin gesetzt und mit euren Vorschlägen gebastelt.

Daraus habe ich jetzt eine läsung erstellt die für mich geht. Entschudligt wenn es so aussieht das es sehr deletantisch zusammen gebalstelt ist.

Code:

'Kanten abziehne wenn die Kante stärker als das "Max_Fügemaß" ist oder Platte oder Belag nicht gefügt werden kann
    Dim LA As Integer
    For LA = Cells(Rows.Count, 5).End(xlUp).Row To 1 Step -1
    Dim vRetP As Variant
    Dim vRetBI As Variant
    Dim vRetBA As Variant

   
    vRetP = Application.IfError(Application.VLookup(Worksheets("zwischenablage").Cells(LA, 3), Worksheets("Lager").Range("A2:K1048576"), 11, False), "x")
    vRetBI = Application.IfError(Application.VLookup(Worksheets("zwischenablage").Cells(LA, 8), Worksheets("Lager").Range("A2:K1048576"), 11, False), "x")
    vRetBA = Application.IfError(Application.VLookup(Worksheets("zwischenablage").Cells(LA, 9), Worksheets("Lager").Range("A2:K1048576"), 11, False), "x")


    If Left(Cells(LA, 12).Value, 3) = "KA_" Then
        If CDec(Mid(Cells(LA, 12), InStrRev(Cells(LA, 12), "X") + 1)) > Range("Max_Fügemaß") Or _
        vRetP <> ("x") Or _
        vRetBI <> ("x") Or _
        vRetBA <> ("x") Then
        Cells(LA, 19).Value = Cells(LA, 19) - Mid(Cells(LA, 12), InStrRev(Cells(LA, 12), "X") + 1)
        End If
    End If
   
   

    If Left(Cells(LA, 13).Value, 3) = "KA_" Then
        If CDec(Mid(Cells(LA, 13), InStrRev(Cells(LA, 13), "X") + 1)) > Range("Max_Fügemaß") Or _
        vRetP <> ("x") Or _
        vRetBI <> ("x") Or _
        vRetBA <> ("x") Then
        Cells(LA, 19).Value = Cells(LA, 19) - Mid(Cells(LA, 13), InStrRev(Cells(LA, 13), "X") + 1)
        End If
    End If
   
   
   
    If Left(Cells(LA, 10).Value, 3) = "KA_" Then
        If CDec(Mid(Cells(LA, 10), InStrRev(Cells(LA, 10), "X") + 1)) > Range("Max_Fügemaß") Or _
        vRetP <> ("x") Or _
        vRetBI <> ("x") Or _
        vRetBA <> ("x") Then
        Cells(LA, 20).Value = Cells(LA, 20) - Mid(Cells(LA, 10), InStrRev(Cells(LA, 10), "X") + 1)
        End If
    End If



    If Left(Cells(LA, 11).Value, 3) = "KA_" Then
        If CDec(Mid(Cells(LA, 11), InStrRev(Cells(LA, 11), "X") + 1)) > Range("Max_Fügemaß") Or _
        vRetP <> ("x") Or _
        vRetBI <> ("x") Or _
        vRetBA <> ("x") Then
        Cells(LA, 20).Value = Cells(LA, 20) - Mid(Cells(LA, 11), InStrRev(Cells(LA, 11), "X") + 1)
        End If
    End If
 
       
       
    Next LA
   
    LA = Empty
    vRetP = Empty
    vRetBI = Empty
    vRetBA = Empty

Danke für eure Hilfe und die Gedult.

Schönes Wochenende
Flo