Code erweitern

[Janush]

Sehr gut Gast123, diese Verkürzung passt durchaus in unsere "neue" Funktion, also noch ist der Brei nicht verdorben ich finds ja auch immer ganz gut wenn es ein Gemeinschaftsprojekt wird.

@Dietmar: Du hast Recht, in meinen Codeschnipseln ist alles rausgeflogen, außer den Bemerkungen. Ich denke wir sollten alles nach und nach wieder einbauen. Aber dann so, dass die Übersichtlichkeit nicht verloren geht.

Es sei denn du hast es ganz eilig, dann schicke ich dir die Exceldatei.

[Janush]

Code:

If Zelle.Value <> "" Then

            Zelle.Offset(0, 21).Value = "SM4"

        Else

            Zelle.Offset(0, 21).Value = "" ' Spalte Y leeren

        End If

Dieser Code...es ist klar was er macht. Wenn eine Materialnummer drin steht, soll in Y SM4 stehen. Aber warum ist das so? Was bedeutet SM4?

Das würde ich dynamisch machen basierend auf dem Namen des Parent Worksheets.

Ach was sollst, machen wir den Rest gleich mit rein

Code:

Public Sub BemerkungVonMaterialNrSchreiben(ByRef auftragsZeile As Range)

With auftragsZeile

    'Sub auf die Schneid Tabellen begrenzen
    If InStr(1, .Parent.Name, "Schneid", vbTextCompare) = 0 Then Exit Sub
   
    Dim intIndex As Integer
    Dim strText  As String
   
    'auftragsZeile.Cells(2).Value  = Leergut
    'auftragsZeile.Cells(4).Value  = Material Nummer
    'auftragsZeile.Cells(23).Value = Bemerkungen

    Select Case .Cells(4).Value
        'Rechts links
        Case "2069692", "2068694", "2069693", "2061538", "2061536", "2070577", "2073630", _
             "2079335", "2060109", "2068440", "2067661", "2066453", "2072135", "2065663", _
             "2073641", "2073627", "2073140", "2074487", "2073642", "2073644", "2081273", "2072030"
             
             intIndex = 6: strText = "links rechts Markierung"
       
         'KZ48
        Case "2066150", "2068006", "2068007", "2068008", "2068009", "2069288", "2069289", _
             "2069351", "2069352", "2069947", "2070379", "2070598", "2070599", "2070623", _
             "2070627", "2071522", "2071617", "2071618", "2071619", "2071620", "2071621", _
             "2071622", "2071636", "2071782", "2071830", "2072503", "2072504", "2073969", _
             "2073972", "2074563", "2075364", "2076374", "2076815", "2077936", "2078006", _
             "2078007", "2078213", "2078265", "2078266", "2078317", "2078377", "2078531", _
             "2078646", "2078882", "2079639", "2079640", "2079703", "2079881", "2080309", _
             "2081008", "2072507", "2072506", "2069353"
       
             intIndex = 6: strText = "Autoreflex nur Rohglas mit  KZ48 verwenden"
       
        Case "2079689": intIndex = 6: strText = "Super-Autoreflex nur Rohglas mit  KZ45 verwenden"
       
        Case "2075086", "2075524", "2075525", "2075527", "2075528", "2075529", "2075530", _
             "2075531", "2075532", "2075533", "2075534", "2075537", "2075540", "2075541", _
             "2075542", "2075543", "2075545", "2075547", "2075548", "2075555", "2076253", _
             "2077595", "2077653", "2077812", "2077864", "2078112", "2079199", "2079712", _
             "2079713", "2079715", "2079716", "2084793", "2074158", "2074275", "2079187", "2085516"
       
             intIndex = 6: strText = "Carlex  KZ91 verwenden"
       
        'orange Paletten
        Case "2077050": intIndex = 0: .Cells(2).Value = "Tampere (YF)": strText = "nur hohe orange Palette möglich"
        Case "2075410": intIndex = 0: .Cells(2).Value = "Tampere (YF)": strText = "nur hohe orange Palette möglich"
        Case "2068610": intIndex = 0: .Cells(2).Value = "Tampere (YF)": strText = "nur orange Palette möglich"
        Case "2077973": intIndex = 0: .Cells(2).Value = "Solar (YS)": strText = "Solar Palette"
        Case "2073773": intIndex = 0: .Cells(2).Value = "Tampere (YF)": strText = "nur orange Palette möglich"

        Case Else: intIndex = -4142: 'strtext = "" ' Spalte W leeren
    End Select
   
    'Prüfen ob Materialnummer gefunden wurde
    If Len(strText) > 0 Then
       
        'Prüfen ob Text bereits enthalten ist
        If InStr(1, .Cells(23).Value, strText, vbTextCompare) = 0 Then
            .Cells(23).Value = .Cells(23).Value & ", " & strText
        End If
       
        'Wenn eine Materialnummer gefunden wurde
        'letzte 3 Zeichen des Blattnamens in Y schreiben
        .Cells(25).Value = Right(.Parent.Name, 3)
       
    Else
   
        'Wenn keine Materialnummer gefunden wurde Y leeren
        .Cells(25).Value = ""
   
    End If
   
    'Zeile einfärben
    Range(.Cells(1), .Cells(26)).Interior.ColorIndex = intIndex
   
End With

End Sub

Hier ist die neue BemerkungVonMaterialNrSchreiben inklusive der Änderungen von Gast123. Diese setzt jetzt eine Farbe und schreibt in Äbhängikeit ob eine passende Materialnummer gefunden wurde ein SMX in Y. Schau mal ob du damit leben kannst.

SMX wird gelöscht, sollte die Materialnummer nicht in deiner Datenbank vorhanden sein, selbst wenn in Spalte D etwas drinsteht.

[DietmarD]

Hallo Janush,

funktioniert mit dem Code von Gast 123
Die Private Sub Worksheet_Change(ByVal Target As Range)  habe ich in den einzelnen Tabellenblatt mit dem richtigen Tabellenblatt geändert.

Es gibt einen kleinen Schönheitsfehler in der Spalte W wird jetzt vor dem Text ein Komma gesetzt, alles andere sah gut aus 

Gemeinschaftsprojekt hört sich gut an, Zeit habe ich auch, das heißt wir arbeiten uns hier Stück für Stück vor, außerdem lernt man was dabei und Spaß
macht es auch. 

Eine Lösung die Daten benutzerfreundlich aus einem anderen Tabellenblatt zu holen gefällt mir, wäre es aufwendig dies zu realisieren?  
 
 SM4 ist der Name der Anlage an der geschnitten wird. Da ich alle Schneidprogramme per Makro in einer Archivliste ohne Duplikate in einem Tabellenblatt abspeichere, kann ich später über Filter in der entsprechenden Anlage (SM4) besser suchen. 

[Janush]

Es gibt einen kleinen Schönheitsfehler in der Spalte W wird jetzt vor dem Text ein Komma gesetzt.

Ja das war eigentlich dafür gedacht, damit sich die Bemerkung von eventuell schon vorhandenem Text abhebt. Da müsste man noch eine individuelle Prüfung einbauen. Das machen wir aber morgen

Was du jetzt noch machst, ist das Folgende:

Alle Change Events aus den einzelnen Worksheets rausschmeisen. Und den folgenden Code in das globale Workbook DieseArbeitsmappe einbauen.

Code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    'Sub auf die Schneid Tabellen begrenzen
    If InStr(1, Sh.Name, "Schneid", vbTextCompare) > 0 Then
        'Trigger range festlegen
        If Target.Column = 4 Or Target.Column = 24 Then
       
            'Materialnummer verarbeiten (Übergabe der gesammten Zeile in der wir uns befinden)
            If Target.Column = 4 Then Call BemerkungVonMaterialNrSchreiben(Sh.Rows(Target.Row))
           
            'Kundenauswertung feuert in jedem Fall
            Call BemerkungVonKundenSchreiben(Sh.Rows(Target.Row))
           
        End If
    End If
   
End Sub

Jetzt brauchst du das nicht immer neu in jede Tabelle einbauen.

Wie du bestimmt gesehen hast, wird hier eine neue Sub gecalled -> BemerkungVonKundenSchreiben. Also muss der folgende Code noch in dein Module wo auch der Code der Materialnummer drin ist.

Code:

Public Sub BemerkungVonKundenSchreiben(ByRef auftragsZeile As Range)

With auftragsZeile

    'Sub auf die Schneid Tabellen begrenzen
    If InStr(1, .Parent.Name, "Schneid", vbTextCompare) = 0 Then Exit Sub
   
    Dim strText  As String
   
    'auftragsZeile.Cells(23).Value = Bemerkungen
    'auftragsZeile.Cells(24).Value = Kunde

    Select Case .Cells(24).Value
        Case "Aken", "Witten", "AGP", "Guardian": strText = "Beleg drucken"
    End Select
   
    'Prüfen ob Text bereits enthalten ist
    If InStr(1, .Cells(23).Value, strText, vbTextCompare) = 0 Then
        .Cells(23).Value = .Cells(23).Value & ", " & strText
    End If
   
End With

End Sub

So, damit haben wir alle Grundfunktionen abgehakt. Ab jetzt folgen nur noch Optimierungen und Schönheitskorrekturen

Bei Fragen nur zu.

Schöne Grüße

[DietmarD]

Hallo Janush,

hatte gerade etwas wenig Zeit, deshalb erst jetzt meine Antwort.

Habe deine Anweisungen befolgt.

Funktioniert fast 

Wenn ich meine Eingaben von links nach rechts eingebe, also Leergut und dann die Materialnummer dann funktioniert die Geschichte wie gewünscht.
Steht zuerst die Materialnummer und der damit erzeugte Bemerkungstext in den Zellen, dann wird beim Kundeneintrag der Druckbefehl nicht nachgetragen.   

Danke für deinen Einsatz hier.

[Janush]

Hi Dietmar,

ich habe es gerade nochmal getestet und bei mir gehts. Wie gehst du genau vor? Du trägst den Kunden schon in Spalte X ein, oder?

Momentan reagiert das Makro nur auf Eingaben in D und X.

Schöne Grüße

[DietmarD]

Hi Janush,

der Kunde wir in den meisten Fällen über eine Formel ermittelt dazu
muss erst das Leergut in Spalte B gewählt werden.
Wenn dies nicht die erste Eingabe ist, sondern die Materialnummer als erstes eingegeben wir, was durchaus vorkommt, wird der erste Bemerkungstext gesetzt danach wähle ich das Leergut bzw. den Kunde dann wird Beleg drucken nicht nachgeliefert.

Zweiter Fall ich habe mich bei der Eingabe vertan und der Text steht in der Bemerkungsspalte dann korrigiere ich das Leergut bzw. den Kunde dann wird der Text nicht geändert oder gelöscht sondern bleibt erhalten.

[Janush]

Hi Dietmar,

die Auswertung einer Formel löst nicht das Change-Event eines Worksheets aus. Dazu müssen wir einfach nur die Spalte B zusätzlich mit in unseren Eventlistener aufnehmen.

Code:

If Target.Column = 2 Or Target.Column = 4 Or Target.Column = 24 Then

Der Rest wird etwas komplizierter. Dazu müssen wir noch ein bisschen was programmieren.

Ich melde mich später nochmal mit mehr Infos

[Janush]

Soooooo, dieses Projekt ist ein gutes Beispiel dafür, wie aus einem vermeintlich einfachen Problem ein doch recht komplexes Unterfangen wird. Dadurch, dass es so viele unterschiedliche Variablen gibt, muss man auch einiges abfangen.

Z.B.: In welcher Reihenfolge werden die Daten eingegeben? Zuerst der Kunde und dann die Materialnummer? Wenn ja, dann steht "Beleg Drucken" vor dem eigentlichen Kommentar. Wahrscheinlich kein Problem, aber eben auch nicht hübsch

Dann: Was passiert wenn man sich verschrieben hat? Dann muss ja der falsche Kommentar verschwinden und der neue gesetzt werden. Woher weiß das Makro welcher Teil des Kommentars weg muss

Muss vor den Kommentar ein Komma gesetzt werden, oder nicht? Wenn noch nichts in der Zelle steht dann nicht, aber wenn doch dann schon, sonst verschmelzen die Kommentare.

Wenn man all diese Dinge berücksichtigen will, muss man schon bisschen was basteln....aber es macht ja auch Spass. Ist ein bisschen wie wenn man eine Maschine baut

Die Lösungen für alle Probleme kommen jetzt:

Wir haben eine extra Sub für das einfügen von Kommentaren. Diese bekommt die Zeile und den Kommentar übergeben und prüft ob schon etwas in der Zielzelle steht und setzt jeh nach dem ein Komma, oder nicht. Diese Sub gehört in das selbe Modul wie "BemerkungVonMaterialNrSchreiben"

Code:

Private Sub BemerkungSchreiben(ByRef auftragsZeile As Range, ByVal bemerkung As String)

With auftragsZeile

    'Bemerkung Text enthält
    If Len(bemerkung) > 0 Then
       
        'Prüfen ob bereits Text enthalten ist
        'wenn ja Komma anhängen
        If Len(.Cells(23).Value) > 0 Then
            .Cells(23).Value = .Cells(23).Value & ", "
        End If
       
        'Bemerkung schreiben
        .Cells(23).Value = .Cells(23).Value & bemerkung
   
    End If
   
End With

End Sub

Dann werden jetzt alle Bemerkungen vordefiniert, damit wir irgendwie Zugriff darauf bekommen und diese auch wieder löschen können.

Dazu brauchen wir zuerst ein globales Array im Modul ganz oben:

Code:

Option Explicit
Option Private Module

'Globales Array welches alle unsere Bemerkungen enthält
Private varBemerkungen() As Variant

Dann habe ich die beiden alten schreibenden Subs zu einer zusammengeführt. Zusätzlich werden hier alle Bemerkungen definiert. Also "BemerkungVonKundenSchreiben" kommt weg und "BemerkungVonMaterialNrSchreiben" wird durch diesen Code ersetzt:

Code:

Public Sub BemerkungVonMaterialNrSchreiben(ByRef auftragsZeile As Range)

varBemerkungen = Array("links rechts Markierung", _
                       "Autoreflex nur Rohglas mit  KZ48 verwenden", _
                       "Super-Autoreflex nur Rohglas mit  KZ45 verwenden", _
                       "Carlex  KZ91 verwenden", _
                       "nur hohe orange Palette möglich", _
                       "nur orange Palette möglich", _
                       "Solar Palette", _
                       "Beleg drucken")
                      
Call AlleBemerkungenLöschen(auftragsZeile)

With auftragsZeile

    'Sub auf die Schneid Tabellen begrenzen
    If InStr(1, .Parent.Name, "Schneid", vbTextCompare) = 0 Then Exit Sub
   
    Dim intIndex As Integer
    Dim strText  As String
   
    'auftragsZeile.Cells(2).Value  = Leergut
    'auftragsZeile.Cells(4).Value  = Material Nummer
    'auftragsZeile.Cells(23).Value = Bemerkungen

    Select Case .Cells(4).Value
        'Rechts links
        Case "2069692", "2068694", "2069693", "2061538", "2061536", "2070577", "2073630", _
             "2079335", "2060109", "2068440", "2067661", "2066453", "2072135", "2065663", _
             "2073641", "2073627", "2073140", "2074487", "2073642", "2073644", "2081273", "2072030"
             
             intIndex = 6: strText = varBemerkungen(0)
       
         'KZ48
        Case "2066150", "2068006", "2068007", "2068008", "2068009", "2069288", "2069289", _
             "2069351", "2069352", "2069947", "2070379", "2070598", "2070599", "2070623", _
             "2070627", "2071522", "2071617", "2071618", "2071619", "2071620", "2071621", _
             "2071622", "2071636", "2071782", "2071830", "2072503", "2072504", "2073969", _
             "2073972", "2074563", "2075364", "2076374", "2076815", "2077936", "2078006", _
             "2078007", "2078213", "2078265", "2078266", "2078317", "2078377", "2078531", _
             "2078646", "2078882", "2079639", "2079640", "2079703", "2079881", "2080309", _
             "2081008", "2072507", "2072506", "2069353"
       
             intIndex = 6: strText = varBemerkungen(1)
       
        Case "2079689": intIndex = 6: strText = varBemerkungen(2)
       
        Case "2075086", "2075524", "2075525", "2075527", "2075528", "2075529", "2075530", _
             "2075531", "2075532", "2075533", "2075534", "2075537", "2075540", "2075541", _
             "2075542", "2075543", "2075545", "2075547", "2075548", "2075555", "2076253", _
             "2077595", "2077653", "2077812", "2077864", "2078112", "2079199", "2079712", _
             "2079713", "2079715", "2079716", "2084793", "2074158", "2074275", "2079187", "2085516"
       
             intIndex = 6: strText = varBemerkungen(3)
       
        'orange Paletten
        Case "2077050": intIndex = 0: .Cells(2).Value = "Tampere (YF)": strText = varBemerkungen(4)
        Case "2075410": intIndex = 0: .Cells(2).Value = "Tampere (YF)": strText = varBemerkungen(4)
        Case "2068610": intIndex = 0: .Cells(2).Value = "Tampere (YF)": strText = varBemerkungen(5)
        Case "2077973": intIndex = 0: .Cells(2).Value = "Solar (YS)": strText = varBemerkungen(6)
        Case "2073773": intIndex = 0: .Cells(2).Value = "Tampere (YF)": strText = varBemerkungen(5)

        Case Else: intIndex = -4142: 'strtext = "" ' Spalte W leeren
    End Select
   
    Call BemerkungSchreiben(auftragsZeile, strText)
   
    Select Case .Cells(24).Value
        Case "Aken", "Witten", "AGP", "Guardian": strText = varBemerkungen(7)
        Case Else: strText = ""
    End Select
   
    Call BemerkungSchreiben(auftragsZeile, strText)
   
    'letzte 3 Zeichen des Blattnamens in Y schreiben
    .Cells(25).Value = Right(.Parent.Name, 3)
    'Zeile einfärben
    Range(.Cells(1), .Cells(26)).Interior.ColorIndex = intIndex
   
End With

End Sub

Wie du siehst, werden ganz oben alle Bemerkungen in das globale Array geschrieben. Über varBemerkungen(x) wird auf die jeweilige Position zugegriffen.

Jetzt lösen wir noch das letzte Problem dadurch, dass wir einfach alle Bemerkungen löschen bevor überhaupt auf die Materialnummer und den Kunden geprüft wird. Dazu gibts es noch eine neue Sub die sich darum kümmert:

Code:

Private Sub AlleBemerkungenLöschen(ByRef auftragsZeile As Range)

Dim varBemerkung   As Variant
Dim intBemPosition As Integer
   
With auftragsZeile

    For Each varBemerkung In varBemerkungen
   
        intBemPosition = InStr(1, .Cells(23).Value, varBemerkung, vbTextCompare)
       
        If intBemPosition > 0 Then
       
            If intBemPosition > 2 Then
       
                If StrComp(Mid(.Cells(23).Value, intBemPosition - 2, 2), ", ", vbTextCompare) = 0 Then
               
                    varBemerkung = ", " & varBemerkung
               
                End If
               
            End If 'intBemPosition > 2
           
            .Cells(23).Value = Replace(.Cells(23).Value, varBemerkung, "")
       
        End If 'intBemPosition > 0
   
    Next varBemerkung

End With

End Sub

Diese Sub geht durch alle definierten Bemerkungen und löscht diese aus der Tabelle sollte eine oder mehrere davon in der Zelle stehen. Die sieht auch noch etwas aufgebläht aus, denn sie prüft zusätzlich auf eventuele Kommas vor der Bemerkung

Zu guter Letzt kommt hier noch das Change Event welches in DieseArbeitsmappe reingehört um all das auszulösen.

Code:

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

    'Sub auf die Schneid Tabellen begrenzen
    If InStr(1, Sh.Name, "Schneid", vbTextCompare) > 0 Then
        'Trigger range festlegen
        If Target.Column = 2 Or Target.Column = 4 Or Target.Column = 24 Then
       
            'Materialnummer verarbeiten (Übergabe der gesammten Zeile in der wir uns befinden)
            Call BemerkungVonMaterialNrSchreiben(Sh.Rows(Target.Row))
           
        End If
    End If
   
End Sub

Viel Spass und schöne Grüße

[DietmarD]

Hallo Janush,

habe mal wieder etwas Zeit gefunden an unserem Projekt weiter zuarbeiten.
Ich habe im Moment einiges um die Ohren, deshalb erst jetzt meine späte Antwort, tut mir leid. 

Du hast mir einen Codeschnipsel  gesendet, wo genau kommt der rein?

If Target.Column = 2 Or Target.Column = 4 Or Target.Column = 24 Then


Ich habe in der Arbeitsmappe diesen im  Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) 

 If Target.Column = 4 Or Target.Column = 24 Then  

damit ersetzt.

Ich hoffe das war richtig.