Das Archiv des Excel-Forums

Muss nochmals um Hilfe bitten bei Makroerstellung

Bild

Betrifft: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Andy

Geschrieben am: 09.10.2003 16:28:26

Muss nochmals um Hilfe bitten...habe zwar eine Antwort mit einer Beispielsdatei erhalten, aber die konnte ich nicht anpassen....

Vielleicht findet sich ja nochmals ein Hilfswilliger, der mir bei meinem Projekt
helfen kann.

Für einen Schichtplan möchte ich Zahlenwerte gleich bei der Eingabe durch ein Makro überprüfen lassen. Und zwar sieht das ganze so aus:

In den Spalten E und G werden Zahlen eingegeben, z.B.
E G
8 7
7 8
8 7
0 0
8 8
6 8
8 7 usw.

Nun soll jedes Zahlenpaar nur dreimal vorkommen dürfen. Wird also zum vierten Mal das Paar 8 und 7 eingegeben, so soll das Makro die Eingabe verweigern und etwa die Fehlermeldung "Variation kommt bereits dreimal vor!" ausgeben. Das Zahlenpaar 7 und 8, also andersrum darf natürlich vorkommen...ist ja auch nicht 8 und 7.

Nun kommt leider erschwerend hinzu, dass diese Regel immer nur für 9 Zeilen (da 9 Mitarbeiter) zählt, also von Zeile 1 - 9, dann von 10 - 18, 19 - 27 usw.

Also...in den jeweils 9 Zeilen darf eine Paarkombination nur dreimal vorkommen.

Wer kann helfen, wer würde mir das Makro schreiben???

Schon jetzt vielen Dank an alle die helfen können und werden..


ANDY
Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Nepumuk
Geschrieben am: 09.10.2003 18:29:56

Hallo Andy,
ich habe jetzt keine Zeit weiterzumachen, hier mal eine Vorabversion.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim zeile1 As Long, zeile2 As Long, bereichszeile As Long, paare As String
Dim pruefen As Integer, zaehler As Integer, merkzeile As Integer, fehler As Boolean
If Target.Column = 5 Or Target.Column = 7 Then
Application.EnableEvents = False
For zeile1 = Target.Row To Target.Row + Target.Count
If Trim(Cells(zeile1, 5)) <> "" And Trim(Cells(zeile1, 7)) <> "" Then
bereichszeile = ((zeile1 - 1) \ 9 + 1) * 9 + 1 - 9
If merkzeile <> bereichszeile Then
paare = ""
For zeile2 = bereichszeile To bereichszeile + 8
If Trim(Cells(zeile2, 5)) <> "" And Trim(Cells(zeile2, 7)) <> "" Then
For pruefen = 1 To Len(paare) Step 2
If Mid(paare, pruefen, 2) = CStr(Cells(zeile2, 5)) & CStr(Cells(zeile2, 7)) Then zaehler = zaehler + 1
Next
If zaehler > 2 Then
Cells(zeile2, 7).Interior.ColorIndex = 3
Cells(zeile2, 7) = CStr(Cells(zeile2, 7)) & " ?"
fehler = True
Else
Cells(zeile2, 7).Interior.ColorIndex = -4142
Do While InStr(1, Cells(zeile2, 7), "?") <> 0
Cells(zeile2, 7) = Mid(Cells(zeile2, 7), 1, InStr(1, Cells(zeile2, 7), "?") - 1)
Loop
End If
paare = paare & CStr(Cells(zeile2, 5)) & CStr(Cells(zeile2, 7))
zaehler = 0
End If
Next
merkzeile = bereichszeile
End If
End If
Next
Application.EnableEvents = True
If fehler Then MsgBox "Die rot Markierten Zellen enthalten Parungen die mehr als drei mal vorkommen.", 16, "Warnung"
End If
End Sub


Code eingefügt mit: Excel Code Jeanie

Bis später
Nepumuk


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: GraFri
Geschrieben am: 09.10.2003 18:33:27

Hallo



'————————————————————————————————
'   09/10/2003
'©  Ing.Friedrich Grath
'@  grath.fritz@ aon.at
'————————————————————————————————

' Bei Eingabe eines Wertes in Spalte A wird überprüft, ob ein Wert in der
' Nachbarzelle (Spalte B) existiert und die Werteüberprüfung erfolgt
' Ebenso wird bei Eingabe eines Wertes in Spalte B überprüft, ob ein Wert
' in der Nachbarzelle (Spalte A) existiert und die Werteüberprüfung erfolgt.

Option Explicit

Dim Antwort%, Gleich%, n%, xA%, xB%, woher%, ZeilenNummer%


Sub Worksheet_Change(ByVal Target As Excel.Range)

On Error GoTo Fehler
Application.EnableEvents = False

ZeilenNummer = Target.Row

Select Case Target.Column
Case 1      'Spalte A
    woher = 1
    If ActiveCell.Offset(-1, 1) = vbNullString Then
        GoTo Ausstieg
    Else
        xA = ActiveCell.Offset(-1, 0): xB = ActiveCell.Offset(-1, 1)
        Call Prüfe_Paar
    End If
Case 2      'Spalte B
    woher = 2
    If ActiveCell.Offset(-1, -1) = vbNullString Then
        GoTo Ausstieg
    Else
        xA = ActiveCell.Offset(-1, -1): xB = ActiveCell.Offset(-1, 0)
        Call Prüfe_Paar
    End If
End Select

Ausstieg:
Application.EnableEvents = True

Fehler:
End Sub

Sub Prüfe_Paar()

Gleich = 0
For n = 1 + ((ZeilenNummer - 1) \ 9) * 9 To 9 + ((ZeilenNummer - 1) \ 9) * 9
    If Cells(n, 1) = xA Then
        If Cells(n, 2) = xB Then Gleich = Gleich + 1
        If Gleich > 3 Then
            Antwort = MsgBox("Das Zahlenpaar kommt bereits 3 mal vor" & vbCrLf & _
                    "Bitte ändern Sie die Eingabe", vbCritical, "FEHLER")
                    Gleich = 0
            If woher = 1 Then
                Cells(ZeilenNummer, 1).ClearContents: Cells(ZeilenNummer, 1).Activate
            Else
                Cells(ZeilenNummer, 2).ClearContents: Cells(ZeilenNummer, 2).Activate
            End If
            Exit Sub
        End If
    End If
Next n

End Sub


     Code eingefügt mit Syntaxhighlighter 2.4


mfg, GraFri


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Holger Levetzow
Geschrieben am: 09.10.2003 19:20:19

versuche es mal so (Code in das Modulblatt der entsprechenden Tabelle einfügen):


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Or Target.Column = 7 Then
zeile = Target.Row
von = zeile - (zeile - 1) Mod 9
bis = zeile + 8 - (zeile - 1) Mod 9
anzahl = 0
If Target.Value <> "" Then
For z = von To bis
If z <> zeile Then
If Cells(z, 5) = Cells(zeile, 5) And Cells(z, 7) = Cells(zeile, 7) Then anzahl = anzahl + 1
If anzahl >= 3 Then
Target.Value = ""
Range(Target.Address).Select
MsgBox ("Eingabe nicht möglich")
Exit Sub
End If
End If
Next
End If
End If
End Sub

Holger


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Andy
Geschrieben am: 09.10.2003 21:26:08

Hallo Holger,

vielen Dank für Deine Lösung. Ist genau das, was ich benötige.

Ich habe allerdings nur eine Bitte bzw. einen Änderungswunsch. Dein Makro funktioniert perfekt...nur wenn ich in einer Zeile eine 0 eingeben will, also etwa 0 8, dann erhalte ich auch die Fehlermeldung.

Ich nehme an, das liegt daran, weil in den Zeilen darunter noch keine Werte eingetragen sind. Kann man dies noch ändern? Die Fehlermeldung sollte nur dann auftreten, wenn eine Zahlenpaar zum vierten Mal vorkommt (etwa 0 0 oder 0 8 oder 7 0 etc.)

Vielen Dank schon einmal
Andy


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Nepumuk
Geschrieben am: 09.10.2003 21:59:48

Hallo Andi,
soll ich nun weitermachen oder nicht? Versuch mal bei den anderen Ansätzen zwei Zellen gleichzeitig zu ändern bzw. mehrere Zellen in den Bereich rein zu kopieren.
Gruß
Nepumuk


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Andy
Geschrieben am: 10.10.2003 11:04:55

Vielen Dank für Deine Hilfe, Nepumuk.

Aber die Lösung von Holger funktioniert schon. Trotzdem noch mal vielen Dank für Deinen
Einsatz.

Andy


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Holger Levetzow
Geschrieben am: 10.10.2003 07:35:13

dann versuche mal diese kleine Änderung:

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 5 Or Target.Column = 7 Then
zeile = Target.Row
von = zeile - (zeile - 1) Mod 9
bis = zeile + 8 - (zeile - 1) Mod 9
anzahl = 0
If Target.Value <> "" Then
For z = von To bis
If z <> zeile Then
If Cells(z, 5) & "," & Cells(z, 7) = Cells(zeile, 5) & "," & Cells(zeile, 7) Then anzahl = anzahl + 1
If anzahl >= 3 Then
Target.Value = ""
Range(Target.Address).Select
MsgBox ("Eingabe nicht möglich")
Exit Sub
End If
End If
Next
End If
End If
End Sub

Holger


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Andy
Geschrieben am: 10.10.2003 10:52:46

Vielen Dank Holger,

jetzt funktioniert's genau richtig. So kann ich es für unseren Schichtplan benutzen.


Danke!


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Andy
Geschrieben am: 09.10.2003 21:03:38

Erst mal vielen Dank für die drei Lösungen...

werde sie gleich mal probieren und euch in ca. 30 Minuten mitteilen, ob's ok ist.

Vielen Dank.....

Andy


Bild


Betrifft: AW: Muss nochmals um Hilfe bitten bei Makroerstellung
von: Andy
Geschrieben am: 09.10.2003 21:31:16

Erst einmal ganz herzlichen Dank an

-Nepumuk
-GraFi und
-Holger Levetzow.

Ihr habt mir sehr geholfen und Eure Vorschläge waren alle toll. Leider kann ich nur für einen entscheiden.

Trotzdem...noch einmal vielen Dank für Eure Hilfe...

Andy


 Bild