Muss nochmals um Hilfe bitten bei Makroerstellung

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

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

Beliebteste Forumthreads (12 Monate)

Muss nochmals um Hilfe bitten bei Makroerstellung

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread