Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
320to324
320to324
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Muss nochmals um Hilfe bitten bei Makroerstellung

Muss nochmals um Hilfe bitten bei Makroerstellung
09.10.2003 16:28:26
Andy
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

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

Betreff
Datum
Anwender
Anzeige
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
09.10.2003 18:29:56
Nepumuk
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
Anzeige
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
09.10.2003 18:33:27
GraFri
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
Anzeige
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
09.10.2003 19:20:19
Holger Levetzow
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
Anzeige
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
09.10.2003 21:26:08
Andy
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
Anzeige
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
09.10.2003 21:59:48
Nepumuk
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
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
10.10.2003 11:04:55
Andy
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
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
10.10.2003 07:35:13
Holger Levetzow
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
Anzeige
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
10.10.2003 10:52:46
Andy
Vielen Dank Holger,

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

Danke!
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
09.10.2003 21:03:38
Andy
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
AW: Muss nochmals um Hilfe bitten bei Makroerstellung
09.10.2003 21:31:16
Andy
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
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige