FUNKE Gesundheit FUNKE Gesundheit Mein 9monate Anmelden
Suchen Menü
< Themenübersicht + Thema starten

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ßE n 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ßE n 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.
Beitrag melden Antworten
Bisherige Antworten

für mich ist das alles sehr verständlich....


lg michaela
Beitrag melden Antwort kommentieren

Sehr übersichtlich! Kein Problem für uns.... oder ;-)

Beitrag melden Antwort kommentieren

Hmh!?

Hallo Swchen,

also dein Sohn hat echt was drauf - ich arbeite zwar auch am Computer, aber das wäre mir echt zu hoch!

Kannst ihm ruhig mal anerkennend von mir auf die Schulter klopfen!

LG

Beitrag melden Antwort kommentieren

Hmh!?

3. anlauf... immer noch eine große Dose Lob für deinen Sohn.. finde ich total lieb von ihm...
Versteh so ca. 80% von dem ganzen... aber mehr muß ja auch nciht sein .oder? Oder hast du jetzt einen Fehler eingebaut und wer ihn findet darf auf einen Kaffee kommen ??
LG nijesa
Beitrag melden Kommentar kommentieren

nicht schlecht, wird schon mit der zeit

...werden die quelltexte dann auch kürzer ;-)
btw - vba ist keine programmiersprache sondern eine scriptsprache, entsprechend das ergebnis kein programm sondern ein script bzw. makro.
ist fein für den einstieg, da stark vereinfacht und dadurch halt schnelle erfolge.
und sehr gefragt von daher feinerle :-)
bin mir nur nicht so ganz sicher was du hören/lesen willst weil du das script hier postest?
lg,
sonja
Beitrag melden Antwort kommentieren

nicht schlecht, wird schon mit der zeit

hallo erstmal... so ganz hab ich dein posting jetzt echt nicht verstanden sorry...
ich hab weder ahnung davon was "btw" oder "vba" oder "script" oder "makro" ist...
und deinen satz: "und sehr gefragt von daher feinerle :-)" kapier ich auch nicht, meinst du mich mit "feierle"?
ich wollt gar nix hören/lesen hier, und ich hab auch nicht das script (was auch immer das ist) hier gepostet, sondern lediglich paar auszüge von 16 din-a4-seiten...
ich kann mir schon vorstellen, daß die mädels, die auf der hibbelliste sind und das update täglich nutzen damit einen kleinen einblick bekommen könnten... verstehen tut das eh niemand, also zumindest ich nicht.
ich kann deine zeilen auch ehrlich nicht einordnen, "fein für den einstieg, da stark vereinfach und dadurch halt schnelle erfolge" - das ist doch genau passend für hier, oder? denn wer hat schon die zeit, täglich alle updates in der hibbelliste einzeln und manuell zu bewältigen? ich jedenfalls nicht.
lg.
Beitrag melden Kommentar kommentieren

es war an sich ein lob ;-)

Beitrag melden Kommentar kommentieren

auszug aus der hibbellistenprogrammierung...

Hallo swchen,
ich weiß was du hören möchtest ;-):
Es ist super nett von deinem Sohn, dass er sich soviel Arbeit macht, damit du uns die tolle Liste täglich bescheren kannst.
Vielen Dank an euch von mir!
Sabine
Beitrag melden Antwort kommentieren

Versteh nur Bahnhof!!!!!!!!!!!!!1

Beitrag melden Antwort kommentieren

Ja, HIER! *lach*

Hi Swchen,
aber ich bin auch wirklich gelernte Programmiererin, und diese Sprache ist mein täglich Brot! :-)
Ich selbst programmiere ja das Excel von Microsoft um, und da ist die "Sprache" genau gleich (ich weiß ja nicht wo/womit du die Hibbelliste erstellst).
Man mag es ja nicht glauben, aber wenn ich sowas schreiben darf, dann geh ich förmlich auf *lach*
LG, Ilse, die sich morgen wieder den ganzen Tag mit o.g. beschäftigt
Beitrag melden Antwort kommentieren

@ilse80

hallo, schön, wenn jemand das versteht in etwas, was ich nur auszugsweise kopiert habe ja, mein sohn hat das ganze in excel "getan", und ich update nur abend für abend die hibbelliste (hab ne anleitung bekommen, auf welchen button ich wann klicken muß, um dieses und jenes zu tun , aber immerhin kennt sich mein 22-jähriger sohn inwzischen mit dem weiblichen zyklus aus )
lg.
Beitrag melden Kommentar kommentieren
< Themenübersicht Frage beantworten
Meistgelesen auf 9monate.de
Diskussionsverlauf
Rat und Hilfe zur Bedienung
Übersicht aller Foren
Babybauch Schwangerschaft & Geburt
Babybauch Baby & Kind
Mutter mit Baby Leben & Familie
9monate allgemeine Foren 9monate allgemein
Gewinnspiele: Tolle Preise warten!
Gewinnspiele: Tolle Gewinne warten!

Mit der Teilnahme an unseren interaktiven Gewinnspielen sicherst du dir hochwertige Preise für dich und deine Liebsten!

Jetzt gewinnen
Zum Seitenanfang