auszug aus der hibbellistenprogrammierung...

hallo, wen's interessiert, mein sohn hat mir heute 2 weitere dinge eingebaut, damit ich es einfacher habe. es funktioniert echt jetzt vieles per mausklick...
das programm umfaßt mittlerweile 16 a-4 seiten in schriftgröße 12
als ich letztens davon berichtet hatte, waren es 7 seiten (mein programmierer sagte: "na mama, du hast aber auch andauernd neue wünsche!" )
so, nun schaut mal auf ein paar auszüge aus 16 seiten:




Range("A1") = "*****HIBBELLISTE****" & Date + 1
Range("aktliste") = "hier nun die aktuelle Liste für den " & Date + 1
i = Range("aktliste").Row + 1
While Range("A" & i + 1) "-------------------------------------------------------------------------------------------------------------------------------"
Call zeichenersetzen("A" & i)
Range("A" & i).Value = Replace(Range("A" & i).Value, " (bitte melden)", "")
Range("A" & i).Value = Replace(Range("A" & i).Value, " (bitte dringend melden)", "")
dummy = InStr(1, Range("A" & i).Value, "ES+")

If dummy 0 Then
If IsNumeric(Mid(Range("A" & i).Value, dummy + 3, 1)) = True Then y = 1
If IsNumeric(Mid(Range("A" & i).Value, dummy + 4, 1)) = True Then y = 2
suchstring = Mid(Range("A" & i).Value, dummy + 3, y)
ersetzen = (Mid(Range("A" & i).Value, dummy + 3, y) * 1) + 1
Range("A" & i).Value = Application.WorksheetFunction.Substitute(Range("A" & i).Value, "ES+" & suchstring, "ES+" & ersetzen)
Debug.Print i
While Range("A" & i).Value = ""
Debug.Print i
i = i + 1
Wend
While Range("A" & i).Value ""
Call zeichenersetzen("A" & i)
Range("A" & i).Value = Replace(Range("A" & i).Value, " (bitte melden)", "")
Range("A" & i).Value = Replace(Range("A" & i).Value, " (bitte dringend melden)", "")

dummy = InStr(1, Range("A" & i).Value, " ZT ")
If dummy 0 Then
If IsNumeric(Mid(Range("A" & i).Value, dummy + 4, 1)) = True Then y = 1
If IsNumeric(Mid(Range("A" & i).Value, dummy + 5, 1)) = True Then y = 2
suchstring = Mid(Range("A" & i).Value, dummy + 4, y)
If suchstring >= 40 Then
If MsgBox(Mid(Range("A" & i), 1, Application.WorksheetFunction.Find(",", _
Range("A" & i).Value, 1) - 1) & " ist bei ZT " & suchstring & vbCr & vbCr & _
"Soll sie gelöscht werden?", vbYesNo + vbQuestion, "Löschen?") = vbYes Then
Rows(i & ":" & i).Delete xlUp
GoTo weiter2
End If
End If
ersetzen = (Mid(Range("A" & i).Value, dummy + 4, y) * 1) + 1
Range("A" & i).Value = Application.WorksheetFunction.Substitute(Range("A" & i).Value, " ZT " & suchstring, " ZT " & ersetzen)

If ersetzen = 39 Then
Range("A" & i).Value = Range("A" & i).Value & " (bitte melden)"
End If
If ersetzen = 40 Then
Range("A" & i).Value = Range("A" & i).Value & " (bitte dringend melden)"
End If
End If
i = i + 1
weiter2:
Wend
Call xnmt
warteplus
endlosschleife
Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1), "")
Range("heisse2namen") = Replace(Range("heisse2namen").Value, Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1) & ", ", "")
Range("heisse2namen") = Replace(Range("heisse2namen").Value, Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1), "")
Range("lzh") = Replace(Range("lzh").Value, Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1) & ", ", "")
Range("lzh") = Replace(Range("lzh").Value, Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1), "")


If IsNumeric(Mid(Range(ActiveCell.Address).Value, dummy + 3, 1)) = True Then y = 1
If IsNumeric(Mid(Range(ActiveCell.Address).Value, dummy + 4, 1)) = True Then y = 2
suchstring = Mid(Range(ActiveCell.Address).Value, dummy + 3, y)
ersetzen = (Mid(Range(ActiveCell.Address).Value, dummy + 3, y) * 1) + 1
ActiveCell.Value = Application.WorksheetFunction.Substitute(ActiveCell.Value, "ES+" & suchstring, "ZT 2")
neuname = Left(Name, x) + 1 & ".ÜZ"
ActiveCell.Value = Replace(ActiveCell.Value, Name, neuname)
Match = False

For i = Range("aktliste").Row + 1 To ActiveSheet.UsedRange.Rows.Count
If i ActiveCell.Row Then
If Match = False Then
dummy = InStr(1, Range("A" & i).Value, " ZT ")
If dummy = 0 Then
Match = False
Else
Match = True
End If
Else
If Range("A" & i).Value = "" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Cut
Cells(i, 1).Insert xlDown
Exit For
End If
End If
End If
Next
hibbelmakro
Call xnmt
End Sub
Sub ztende()
On Error Resume Next
dummy = InStr(1, Range(ActiveCell.Address).Value, " ZT ")
If dummy = 0 Then
MsgBox "Falsche Zelle angeklickt... ZT wurde nicht gefunden", vbCritical, "Fehler"
Exit Sub
End If
If MsgBox("Hat der Eisprung von " _
& Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1) & " stattgefunden?", vbYesNo + _
vbQuestion, "ES Start?") = vbNo Then Exit Sub

Call zeichenersetzen(ActiveCell.Address)

suchstring, ersetzen)
End If
For i = Range("aktliste").Row + 1 To ActiveSheet.UsedRange.Rows.Count
If Range("A" & i).Value = "" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Cut
Cells(i, 1).Insert xlDown
Exit For
End If
Next
End Sub

Sub ztzuzt()
On Error Resume Next
dummy = InStr(1, Range(ActiveCell.Address).Value, " ZT ")
If dummy = 0 Then
MsgBox "Falsche Zelle angeklickt... ZT wurde nicht gefunden", vbCritical, "Fehler"
Exit Sub
End If
If MsgBox("Soll " _
& Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1) & " wieder unten eingefügt werden?", vbYesNo + _
vbQuestion, "ES Start?") = vbNo Then Exit Sub

Call zeichenersetzen(ActiveCell.Address)
Call kurveloschen(ActiveCell.Address)

dummy = InStr(1, Range(ActiveCell.Address).Value, " ZT ")
If dummy 0 Then
If IsNumeric(Mid(Range(ActiveCell.Address).Value, dummy + 4, 1)) = True Then y = 1
If IsNumeric(Mid(Range(ActiveCell.Address).Value, dummy + 5, 1)) = True Then y = 2
suchstring = Mid(Range(ActiveCell.Address).Value, dummy + 4, y)

ActiveCell.Value = Replace(ActiveCell.Value, Name, neuname)

Match = False

For i = Range("aktliste").Row + 1 To ActiveSheet.UsedRange.Rows.Count
If i ActiveCell.Row Then
If Match = False Then
dummy = InStr(1, Range("A" & i).Value, " ZT ")
If dummy = 0 Then
Match = False
Else
Match = True
End If
Else
If Range("A" & i).Value = "" Then
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Cut
Cells(i, 1).Insert xlDown
Exit For
End If
End If
End If
Next
End Sub
Sub hibbelmakro()
On Error Resume Next
i = Range("aktliste").Row + 1
While Range("A" & i + 1) "-------------------------------------------------------------------------------------------------------------------------------"
dummy = InStr(1, Range("A" & i).Value, "ES+")
If dummy 0 Then
If IsNumeric(Mid(Range("A" & i).Value, dummy + 3, 1)) = True Then y = 1
If IsNumeric(Mid(Range("A" & i).Value, dummy + 4, 1)) = True Then y = 2
If Mid(Range("A" & i).Value, dummy + 3, y) >= 10 And Mid(Range("A" & i).Value, dummy + 3, y) = 19 Then
If MsgBox(Mid(Range("A" & i), 1, Application.WorksheetFunction.Find(",", Range("A" & i).Value, 1)) & " ist bei ES+" & _
Mid(Range("A" & i).Value, dummy + 3, y) & vbCr & vbCr & "Soll sie gelöscht werden?", vbYesNo + vbQuestion, "Löschen?") = vbYes Then
Rows(i & ":" & i).Delete xlUp
GoTo weiter1
End If
End If
If Mid(Range("A" & i).Value, dummy + 3, y) * 1 >= 10 And Mid(Range("A" & i).Value, dummy + 3, y) * 1 = 15 Then
varname = Mid(Range("A" & i), 1, Application.WorksheetFunction.Find(",", Range("A" & i).Value, 1) - 1)
zhbla = zhbla & varname & ", "
End If
If Mid(Range("A" & i).Value, dummy + 3, y) * 1 = 17 Then
Range("A" & i).Value = Range("A" & i).Value & " (bitte melden)"
End If
If Mid(Range("A" & i).Value, dummy + 3, y) * 1 = 18 Then
Range("A" & i).Value = Range("A" & i).Value & " (bitte dringend melden)"
End If
End If
i = i + 1
weiter1:
"Soll sie gelöscht werden?", vbYesNo + vbQuestion, "Löschen?") = vbYes Then
Rows(i & ":" & i).Delete xlUp
GoTo weiter2
End If
End If
'ersetzen = (Mid(Range("A" & i).Value, dummy + 4, y) * 1) + 1
'Range("A" & i).Value = Application.WorksheetFunction.Substitute(Range("A" & i).Value, " ZT " & suchstring, " ZT " & ersetzen)

If ersetzen = 39 Then
Range("A" & i).Value = Range("A" & i).Value & " (bitte melden)"
End If
If ersetzen = 40 Then
Range("A" & i).Value = Range("A" & i).Value & " (bitte dringend melden)"
End If
End If
i = i + 1
weiter2:
Wend


Call xnmt
checkspruch

Range(ActiveCell.Address).Value, 1) - 1) & ", ", "")
Range("heisse2namen") = Replace(Range("heisse2namen").Value, Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1), "")

Range("lzh") = Replace(Range("lzh").Value, Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1) & ", ", "")
Range("lzh") = Replace(Range("lzh").Value, Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1), "")


varname = Replace(Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", Range(ActiveCell.Address).Value, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) + 1) - 1), ",", "")

varwort = Range("ss").Value & ", " & varname & " (" & Format(Date, "DD.MM.YY") & ")"


'Debug.Print varwort
'varwort = Mid(varwort, 1, Len(varwort) - 1)
Range("ss").Value = varwort
'Debug.Print varwort
'Range("ss").Value = Range("ss").Value & ", " & Mid(Range(ActiveCell.Address), 1, Application.WorksheetFunction.Find(",", _
Range(ActiveCell.Address).Value, 1) - 1)

Range(ActiveCell.Address).Value = Replace(Range(ActiveCell.Address).Value, " (bitte melden)", "")
Range(ActiveCell.Address).Value = Replace(Range(ActiveCell.Address).Value, " (bitte dringend melden)", "")
dummy = InStr(1, ActiveCell.Value, " If dummy 0 Then schwangerzwei

Rows(ActiveCell.Row & ":" & ActiveCell.Row).Delete xlUp
Call
Range("A" & i).Value, 1) - 1)
hibbel2 = hibbel2 & varname & ", "
varx = varx + 1
End If
i = i + 1
End If
Wend

If varx = 1 Then varwort = "hat" Else varwort = "haben"
If hibbel2 "" Then
Range("heisse2") = "span style=" & """" & "color:#0000CC" & """" & "bNMT (nichtmenstermin) " & varwort & "/b/span am " & Date + 1 & ":"
Range("heisse2namen") = Mid(hibbel2, 1, Len(hibbel2) - 2)
Range("heisse2namen").Offset(1, 0).Value = "---> *ganzdolldaumendrück*"
Else
Range("heisse2") = "NMT (nichtmenstermin) hat am " & Date + 1 & ":"
Range("heisse2namen").Value = "leider niemand"
Range("heisse2namen").Offset(1, 0).Value = ""
End If

End Sub

'MsgBox vstring
End If
End Sub

Sub schwangerzwei()
On Error Resume Next
varZeile = ThisWorkbook.Sheets("Liste").Range("schwanger2").Row

While Range("A" & varZeile).Value ""
varZeile = varZeile + 1
Wend

Rows(ActiveCell.Row & ":" & ActiveCell.Row).Copy
Rows(varZeile & ":" & varZeile).Insert Shift:=xlDown

dummy = InStr(1, Cells(varZeile, 1), "ES+")
If dummy 0 Then
If IsNumeric(Mid(Cells(varZeile, 1), dummy + 3, 1)) = True Then y = 1
If IsNumeric(Mid(Cells(varZeile, 1), dummy + 4, 1)) = True Then y = 2
suchstring = " ES+" & Mid(Cells(varZeile, 1), dummy + 3, y)
End If
Cells(varZeile, 1) = Application.WorksheetFunction.Substitute(Cells(varZeile, 1), suchstring, "")
End Sub

Sub warteplus()
On Error Resume Next
varZeile = ThisWorkbook.Sheets("Liste").Range("warteschleife").Row

While Range("A" & varZeile).Value ""
du
Wend
End Sub

Sub checkspruch()
dummy = Replace(Range("heisse"), ",", "")
dummy = Len(Range("heisse")) - Len(dummy)

If dummy > 0 Then
Range("Spruch").Value = "hier die mädels, die ab es+10 (bis es+13, dann geht?s zum nmt) in der HEIßEn SUPER-HIBBEL-PHASE sind:"
Range("Spruch2").Value = "---> für euch geht es zum endspurt! *hibbelhibbelhibbel*"
Else
Range("Spruch").Value = "hier das mädel, die ab es+10 (bis es+13, dann geht?s zum nmt) in der HEIßEn SUPER-HIBBEL-PHASE
Sub vorschaubitte()

Open ThisWorkbook.Path & "/dummy.htm" For Output As #1
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, ""
Print #1, "

"
For i = 1 To ThisWorkbook.Sheets("Liste").UsedRange.Rows.Count
Print #1, Range("A" & i).Value & "
"
Next
Print #1, "

"
Print #1, ""
Print #1, ""
Close #1

Call ShellExecute(hWnd, "open", ThisWorkbook.Path & "/dummy.htm", "", "", _
1)
End Sub
If IsNumeric(Mid(Range("A" & startzeile).Value, esdummy + 4, 1)) = True Then y = 2
suchstring1 = Mid(Range("A" & startzeile).Value, esdummy + 3, y)
suchstring1 = suchstring1 * 1
ersetzen = ersetzen * 1
'Debug.Print ersetzen & "||" & suchstring1
If startzeile aktzeile Then
If ersetzen > suchstring1 Then
Range("A" & aktzeile).Cut
Range("A" & startzeile).Insert xlDown
Exit Sub
End If
End If
startzeile = startzeile + 1
Wend
Range("A" & aktzeile).Cut
Range("A" & startzeile).Insert xlDown
Else
If IsNumeric(Mid(Range(ActiveCell.Address).Value, ztdummy + 4, 1)) = True Then y = 1
If IsNumeric(Mid(Range(ActiveCell.Address).Value, ztdummy + 5, 1)) = True Then y = 2
suchstring = Mid(Range(ActiveCell.Address).Value, ztdummy + 4, y)
ersetzen = InputBox("Gib bitte den richtigen Wert ein" & vbCrLf & vbcrl & vbCrLf & vbCrLf & vbCrLf & vbCrLf & " ZT ", "Nur Zahlen eingeben", suchstring)
aktzeile = ActiveCell.Row
If ersetzen = "" Or IsNumeric(ersetzen) = False Then Exit Sub
Range(ActiveCell.Address).Value = Application.WorksheetFunction.Substitute(Range(ActiveCell.Address).Value, "ZT " & suchstring, "ZT " & ersetzen)
startzeile = Range("ztlistestart").Row + 1
While Range("A" & startzeile).Value ""
ztdummy = InStr(1, Range("A" & startzeile), " ZT ")
If IsNumeric(Mid(Range("A" & startzeile).Value, ztdummy + 4, 1)) = True Then y = 1
If IsNumeric(Mid(Range("A" & startzeile).Value, ztdummy + 5, 1)) = True Then y = 2
suchstring1 = Mid(Range("A" & startzeile).Value, ztdummy + 4, y)

End If
End If
startzeile = startzeile + 1
Wend
Range("A" & aktzeile).Cut
Range("A" & startzeile).Insert xlDown
'ZT ÄNDERN
End If

End Sub


Private Sub CommandButton1_Click()
ausführen
checkspruch
lzhaelfte
End Sub

Private Sub CommandButton2_Click()
esende
checkspruch
lzhaelfte
End Sub

Private Sub CommandButton3_Click()
ztende
checkspruch
lzhaelfte
End Sub

Private Sub CommandButton4_Click()
kopieren
checkspruch
lzhaelfte
End Sub

Pr
Private Sub CommandButton7_Click()
vorschaubitte
End Sub

Private Sub CommandButton8_Click()



ich bin sicher: ihr versteht genau so wenig, wie ich? oder paar programmierer unter uns?

lg.