Registriert seit: 09.09.2021
Version(en): 365
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.
Registriert seit: 09.09.2021
Version(en): 365
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.
Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
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.
Gruß
Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
Registriert seit: 09.09.2021
Version(en): 365
Zitat: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
Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
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.
Gruß
Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
Registriert seit: 09.09.2021
Version(en): 365
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
Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
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.
Gruß
Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
Registriert seit: 09.09.2021
Version(en): 365
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
Registriert seit: 09.09.2021
Version(en): 365
24.11.2021, 15:09
(Dieser Beitrag wurde zuletzt bearbeitet: 24.11.2021, 15:10 von 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
Folgende(r) 1 Nutzer sagt Danke an Janush für diesen Beitrag:1 Nutzer sagt Danke an Janush für diesen Beitrag 28
• DietmarD
Registriert seit: 29.09.2016
Version(en): 2007/2010/ 365
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.
Gruß
Dietmar
Damit das Mögliche entsteht, muß immer wieder das Unmögliche versucht werden.
|