Auftragsformular in Excell

Moin an die Gemeinde...

Excellversion=2007
lediglich Anfängerkenntnisse in Excell vorhanden

In mühevoller Kleinarbeit und Hilfe von aussen, ist es mir weitgehenst gelungen in Excell ein kleines Auftragsformular zu erstellen. Beim testen dieses Formulares habe ich dann einige Schwachstellen entdecken müssen, welche ich gerne noch beseitigen möchte.
1) Beim Auslösen des Commandbuttons "speichern" werden die erfassten Daten in eine Tabelle geschrieben und es wird eine neue Excelldatei auf die Festpallte geschrieben, als Namen wird die Auftragsnummer vergeben.Ein weiterers klicken auf diesen Button löst eine Meldung aus "Datensatz schon vorhanden" das ist auch gewollt so. Jedoch die neue Excelldatei wird überschrieben was eigentlich nicht Sinn dieser Sache sein kann. Es gilt zu verhindern das diese Datei überschrieben wird.
2)Ich musste weiterhin feststellen das ich Datensätze überarbeiten muss und habe mir eine neues Blatt erstellt "Storno" in welches ich die Daten aus der Datentabelle auslesen und überarbeiten kann.
a) Wie kann ich diesen Datensatz in die gleiche Zelle zurückschreiben?
b) Beim speichern auf die Festblatte erhält diese Datei wieder den Namen der Auftragsnummer mit dem Zusatz das diese geändert wurde (Beispiel: von 00001_08_AU auf 00001_08_GÄ) . Hier taucht das gleiche Problem wie unter 1) schon beschrieben, es gilt diese Datei vor ungewolltem überschreiben zu schützen.

ich bedanke mich vorab für eure Hilfe
kiko

 

Hi,

ich habe z.Z. kein Excel2007 und im konvertierten Zustand kann ich deine Schaltflächen nicht benutzen, deshalb als einfaches Makro. Punkt 1 und Punkt 3 sollten nach diesem Prinzip funktionieren

Code:

Sub Auftrag_zurückschreiben()
    Dim WS As Worksheet, WB As Workbook
    Dim fsO
    'Dim VBCom As VBComponent, CModul As CodeModule
    Dim Pfad As String
    Pfad = ThisWorkbook.Path & Application.PathSeparator & "" & Range("I1").Text & Range("L1").Text & "_ÄN" & ".xlsx"
    Pfad = Replace(Pfad, "/", "_")
    Set fsO = CreateObject("Scripting.FileSystemObject")
    If fsO.fileexists(Pfad) Then
        strAbfrage = MsgBox("Soll die vorhandene Arbeitsmappe " & Pfad & " überschrieben werden", vbYesNo)
        If strAbfrage = vbNo Then
            Exit Sub
        End If
    End If
    Set WS = ThisWorkbook.Worksheets("Storno")
    WS.Cells.Copy
    Set WB = Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
    Application.DisplayAlerts = False
    WB.SaveAs Pfad
    Application.DisplayAlerts = True
'    For Each VBCom In ActiveWorkbook.VBProject.VBComponents
'        Set CModul = VBCom.CodeModule
'        If Not CModul Is Nothing Then
'            If CModul.CountOfLines > 0 Then
'                CModul.DeleteLines 1, CModul.CountOfLines
'            End If
'        End If
'    Next VBCom
    WB.Close
    Dim Lst As Worksheet, Frm As Worksheet, Zelle As Range
    Dim z As Long
    Set Lst = Sheets("Storno")
    Set Frm = ActiveSheet
End Sub

Die auskommentierten Zeilen benötigst du m.W. nicht, da beim Speichern einer .XLSM als .XLSX jeglicher Code automatisch aus der Mappe gelöscht wird.

 

Hi,

um die geänderten Daten wieder in die Tabelle "Rechnung" (nehme ich an) zurück zu schreiben, kannst du folgenden Code verwenden

Code:

Sub Aenderungen_uebertragen()
    Dim loZeile As Long
    Dim wsTabelle As Worksheet
    Set wsTabelle = Worksheets("Storno")
    With Worksheets("Rechnung")
        For loZeile = 2 To IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            If .Cells(loZeile, 9) = wsTabelle.Range("D3") Then
                .Cells(loZeile, 4) = wsTabelle.Range("S1")
                ' hier den Code erweitern um die restlichen Einträge/Zellen
                Exit For
            End If
        Next loZeile
    End With
End Sub

 

Hallo Beverly,
ich sage erstmal Danke für die Hilfe zu Punkt 1 und 3.
In beiden Punkten hat Dein Script das gemacht wass es sollte, bis auf einen kleinen Fehler... Beide neu ertstellten xlsx Dateien werden erstellt, allerdings ohne jeglichen Inhalt. Ziel ist es eigentlich das die aktive Seite und nur diese, als neue Datei gespeichert werden sollte. Auch sollten in der neuen Datei keinerlei Buttons oder so gespeichert werden. Der bisherige Code ist:
Private Sub Daten_in_Tabelle_Click()

Dim WS As Worksheet, WB As Workbook
Dim Eintrag As OLEObject, i As Long
'Dim VBCom As VBComponent, CModul As CodeModule
Dim Pfad As Variant

Set WS = ThisWorkbook.ActiveSheet

Pfad = ThisWorkbook.Path & Application.PathSeparator & "" & Range("M1").Text & Range("P1").Text & "_A" & ".xlsx"


Pfad = Replace(Pfad, "/", "_")

Set WB = Workbooks.Add
WS.Copy Before:=WB.Sheets(1)

Application.DisplayAlerts = False

For i = WB.Sheets.Count To 2 Step -1
WB.Sheets(i).Delete
Next

For Each Eintrag In WB.Sheets(1).OLEObjects
Eintrag.Delete
Next Eintrag

For Each VBCom In ActiveWorkbook.VBProject.VBComponents
Set CModul = VBCom.CodeModule
If Not CModul Is Nothing Then
If CModul.CountOfLines > 0 Then
CModul.DeleteLines 1, CModul.CountOfLines
End If
End If
Next VBCom

WB.SaveAs Pfad

Application.DisplayAlerts = True
WB.Close


Dim Lst As Worksheet, Frm As Worksheet, Zelle As Range
Dim z As Long
Set Lst = Sheets("Rechnung")
Set Frm = ActiveSheet


' nächste freie Zeile ermitteln
z = Lst.Range("A65536").End(xlUp).Row + 1

For Each Zelle In Lst.Range("A1:A" & z - 1)
If Zelle.Text & Zelle.Offset(0, 1).Text = _
Frm.Range("M1").Text & Frm.Range("P1").Text Then
MsgBox "Eintrag bereits vorhanden", vbOKOnly, "Mitteilung"
Exit Sub
End If
Next Zelle
'Sheets("Rechnung").Unprotect "Passwort"

' Werte eintragen
Lst.Cells(z, 1).Value = Frm.Range("M1").Value 'ReNr
'hier habe ich wegen der länge des Textes alle Zeilen entfern'Lst.Cells(z, 40).Value = Frm.Range("A37").Value 'Materialbedarf

Sheets("Rechnung").Select
'ActiveSheet.Protect "Passwort"
ThisWorkbook.Save
Exit Sub

End Sub



lg Kiko

 

Hi,

wie ich schon geschrieben habe, kann ich es im Augenblick nicht in Excel2007 testen - geht erst heute Abend. Bei mir (Excel2003) funktionert der Code richtig: es wird die Tabelle "Storno" komplett kopiert, in eine neue Arbeitsmappe eingefügt, anschließend die Schaltflächen gelöscht und unter dem entsprechenden Namen abgespeichert. In der gespeicherten Arbeitsmappe ist auch kein Code vorhanden, weil ja nur die Zellen kopiert werden.

 

Zum Thema:
Hi,
um die geänderten Daten wieder in die Tabelle "Rechnung" (nehme ich an) zurück zu schreiben, kannst du folgenden Code verwenden
mit dem zurückschreiben und dem Code dazu komme ich derzeit nicht klar...
Transfer des Datensatzes ist von Rechnung nach Storno um es dort zu ändern, soweit ist das ok und klappt auch.
Beispiel von Rechnung nach Storno
Rechnung Q13 nach Storno R6
Rechnung R13 nach Storno AA6
----------------
Zurückschreiben wäre dann:
StornoR6 nach Rechnung Q13
StornoAA6 nach Rechnung R13
beim nächsten Datensatz kann es durchaus auch die Zeile 25 oder 30 sein die ich ändern muss... und genau in diese Zeilen müssten die Änderungen zurückgeschrieben werden.
Ich hoffe das ich jetzt nicht Deine Hilfe missbrauche
Danke
kiko

 

Hi,

um den Transfer von Rechnung nach Storno habe ich mich nicht gekümmert, da du ja geschrieben hattest, dass das funktionert.

Der gepostete Code sucht in der Tabelle Rechnung in Spalte 9 nach der Kundennummer aus Zelle D3 der Tabelle Storno - oder welches ist das Kriterium, an welchem du erkennst, aus welcher Zeile der Tabelle Rechnung die Daten nach Tabelle Storno übertragen wurden? Wenn diese Zeilennummer gefunden wurde, werden die Daten aus der Tabelle Storno wieder nach Rechnung übertragen in die gefundene Zeile. An der Stelle wo ich den Vermerk gemacht habe, musst du den Code nach dem selben Prinzip weiterführen, indem du bei .Cells(loZeile, 4) die 4 durch die Spaltennummer ersetzt, in welche geschrieben werden soll. Auf der rechten Seite der jeweiligen Codezeile nach "=" schreibst du dann die Zelle der Tabelle Storno, aus welcher der Wert nach Rechnung übertragen werden soll.

 

Hi...
Ich werde im laufe des Abends den versuch starten, wobei ich eigentlich überzeugt davon bin das es klappt. Das alles hing sicher an der Zelle 9 welche ich falsch interpretiert habe. VBA ist halt ohne Grundkenntnisse recht schwierig.
Wäre noch das Speicherproblem denn eine leere Arbeitsmappe ist nutzlos.
danke sagt kiko

 

Hi,

ich habe mal den Ursprungscode in der hochgeladenen Arbeitsmappe als Grundlage genommen, den Rest kannst du ja nach deinen Bedürfnissen wieder ergänzen

Code:

Private Sub Auftrag_zurückschreiben_Click()
    Dim WS As Worksheet, WB As Workbook
    Dim fsO
    Dim Pfad As String
    Pfad = ThisWorkbook.Path & Application.PathSeparator & "" & Range("I1").Text & Range("L1").Text & "_ÄN" & ".xlsx"
    Pfad = Replace(Pfad, "/", "_")
    Set fsO = CreateObject("Scripting.FileSystemObject")
    If fsO.fileexists(Pfad) Then
        strAbfrage = MsgBox("Soll die vorhandene Arbeitsmappe " & Pfad & " überschrieben werden", vbYesNo)
        If strAbfrage = vbNo Then
            Exit Sub
        End If
    End If
    Set WS = ThisWorkbook.Worksheets("Storno")
    Application.ScreenUpdating = False
    WS.Cells.Copy
    Set WB = Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    WB.SaveAs Pfad
    Application.DisplayAlerts = True
    WB.Close
    Application.ScreenUpdating = True
End Sub

Die Ursache für die leere Arbeitsmappe liegt darin, dass Excell2007 unter Shapes (wie im vorletzten Code gepostet) offensichtlich alles versteht, was sich in der Tabelle befindet, auch Zellen, denn diese wurden komplett gelöscht. Diesen Codeteil habe ich jetzt herausgenommen und so wie oben funktioniert er bei mir in 2007.

Aller Anfang ist schwer - aber mit der Zeit gibt sich das. Das weiß ich aus eigener Erfahrung. Und das Forum hilft dabei wesentlich.

Noch einen Tipp: für die Übersichtlichkeit bei der Programmierung ist es am günstigsten, wenn man alle Variablen am Beginn der Prozedur deklariert und nicht irgendwo zwischendurch, wenn man sie gerade benötigt. Dann hat man alle Variablen auf einen Blick im Griff .

 

Hallo Beverly...
danke für Deine Hilfe, ich kann es garnicht oft genug sagen.
mal kurz zu mir. bis vor 14 Tagen wusste ich nicht einmal was VBA oder gleiches ist, Variablen zurechtlegen nach Plan usw. ist sicher richtig, jedoch weis ich nicht wie und was das alles bedeutet oder wie ich diese anwenden oder interpretieren kann. Das jetztige Projekt ist aus der Not entstanden, es soll sozusagen als Einstieg in den neuen Job dienen, den ich hoffentlich bekomme. Es ist garnicht so einfach mit 55 Jahren und einem Herzinfarkt einen Job zu finden.
Zu Deiner Hilfe bisher, es funktioniert alles so wie es geplant war...Gott(beverly) sei Dank. Einige kleinere Macken sind noch vorhanden, um diese abzustellen bedarf es noch ein wenig Deiner Hilfe.
1) Auftrag erfassen ist ok 2) Auftrag speicher als Datensatz und als Mappe ist ok, solange ich den Button nur einmal auslöse. Nochmaliges Betätigen diese Buttons löst Dein Script aus und fragt ob es überschrieben werden solle ja/nein.
Klicke ich jetzt auf ja, so wird die Mappe überschrieben, jedoch der Datensatz nicht. An diesem Punkt bsollte ebenfalls eine Abfrage überschreiben ja/nein stattfinden... ist das möglich?
3)Ich möchte die einzelen Seiten der Mappe halbwegs sichern, was auch via Script kein Problem darstellt. Im Bedarfsfall wird über das Script der Blattschutz aufgehoben und wieder gesetzt. Es gibt da aber eine Ausnahme die ich nicht geregelt bekomme. Sobald ich vom Stornoformular ins Rechnungformular wechsele um dort einen Datensatz via doppelklick auszuwählen, ist das Blatt gesperrt. Proteckt wird aufgehoben beim Datensatz speichern von Auftrag und von Storno und am Ende dieser Vorgänge wieder gesetzt. Nun die eigentliche Frage: Kann ich Unprotekt zeitlich auf ca 30sek. beschränen? Alternativ solange aktivieren bis ich das Blatt wieder verlasse?
Liebe Grüße
Kiko
Das verwendete Script:

Private Sub Daten_in_Tabelle_Click()

Dim WS As Worksheet, WB As Workbook
Dim fsO
Dim Pfad As String
Pfad = ThisWorkbook.Path & Application.PathSeparator & "" & Range("M1").Text & Range("T1").Text & "_AU" & ".xlsx"
Pfad = Replace(Pfad, "/", "_")
Set fsO = CreateObject("Scripting.FileSystemObject")
If fsO.fileexists(Pfad) Then
strAbfrage = MsgBox("Soll die vorhandene Arbeitsmappe " & Pfad & " überschrieben werden", vbYesNo)
If strAbfrage = vbNo Then
Exit Sub
End If
End If
Set WS = ThisWorkbook.Worksheets("Storno")
Application.ScreenUpdating = False
WS.Cells.Copy
Set WB = Workbooks.Add
ActiveSheet.Paste
Application.CutCopyMode = False
Application.DisplayAlerts = False
WB.SaveAs Pfad
Application.DisplayAlerts = True
WB.Close
Application.ScreenUpdating = True



Dim Lst As Worksheet, Frm As Worksheet, Zelle As Range
Dim z As Long
Set Lst = Sheets("Rechnung")
Set Frm = ActiveSheet


' nächste freie Zeile ermitteln
z = Lst.Range("A65536").End(xlUp).Row + 1

For Each Zelle In Lst.Range("A1:A" & z - 1)
If Zelle.Text & Zelle.Offset(0, 1).Text = _
Frm.Range("M1").Text & Frm.Range("P1").Text Then
MsgBox "Eintrag bereits vorhanden", vbOKOnly, "Mitteilung"
Exit Sub
End If
Next Zelle
Sheets("Rechnung").Unprotect "1"

 

Hi,

so ganz klar ist mir das jetzt nicht. Der von mir geposte Code soll erweitert werden, damit der geänderte Datensatz wieder nach "Rechnung" zurückgeschrieben wird?

Code:

Private Sub Auftrag_zurückschreiben_Click()
    Dim WS As Worksheet, WB As Workbook
    Dim fsO
    Dim Pfad As String
    Dim loZeile As Long
    Pfad = ThisWorkbook.Path & Application.PathSeparator & "" & Range("I1").Text & Range("L1").Text & "_ÄN" & ".xlsx"
    Pfad = Replace(Pfad, "/", "_")
    Set fsO = CreateObject("Scripting.FileSystemObject")
    If fsO.fileexists(Pfad) Then
        strAbfrage = MsgBox("Soll die vorhandene Arbeitsmappe " & Pfad & " überschrieben werden", vbYesNo)
        If strAbfrage = vbNo Then
            Exit Sub
        End If
    End If
    Set WS = ThisWorkbook.Worksheets("Storno")
    Application.ScreenUpdating = False
    WS.Cells.Copy
    Set WB = Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    WB.SaveAs Pfad
    Application.DisplayAlerts = True
    WB.Close
    With Worksheets("Rechnung")
        For loZeile = 2 To IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            If .Cells(loZeile, 9) = WS.Range("D3") Then
                .Cells(loZeile, 4) = WS.Range("S1")
                ' hier den Code erweitern um die restlichen Einträge/Zellen
                Exit For
            End If
        Next loZeile
    End With
    Application.ScreenUpdating = True
End Sub

Erst einmal ohne nochmalige Abfrage ob der Datensatz in der Tabelle "Rechnung" überschreiben werden soll, denn es erfolgt ja bereits eine Abfrage beim Speichern. Ich nehme doch an, dass du den Stornoauftrag nur dann als Datei abspeichern willst, wenn auch der Datensatz überschrieben wird? Oder sehe ich das falsch?

Den Schutz für nur 30 sec. aufzuheben geht vielleicht zu machen (habe ich jetzt nicht getestet), würde ich aber als unpraktisch ansehen. Wenn du beim Bearbeiten gestört wirst und die 30 sec. um sind, wäre die Tabelle ja wieder geschützt. Die bessere Lösung ist, den Schutz beim Verlassen des Tabellenblattes wieder zu setzen. Dazu kann man das Worksheet_Deactivate Ereignis benutzen

Code:

Private Sub Worksheet_Deactivate()
    ActiveSheet.Protect
End Sub

 

Moin Beverly,
Den Blattschutz habe ich auf einfache weise gelöst, eine neue Spalte eingefügt und diese als nicht gesperrt deklariert, so kann ich jede Zeile auswählen und nach Storno übertragen. Die 30 Sek-Lösung wäre dennoch interessant, man weis ja nie wie man es mal braucht.
Bei dem Speicherproblem haben wir aneinander vorbeigeredet. Dein Script im Datenblatt Storno funktioniert eindwandfrei und bedarf keiner Verbesserung. Im Stornoblatt sollen ja auch die Daten bewusst geändert und gespeichert werden. Das Problem liegt im Auftragsformular Ich habe zu dem bestehenden Script Dein Speicherscript eingefügt, wichtiger Teil dieses Scriptes habe ich gestern hochgeladen. Ich steuere über dieses Script 3 Arbeitsgänge, 1) Datensatz ins Datenblatt eintragen, 2) Neue Mappe mit dem Inhalt des Auftrages, 3) Die eigentliche Mappe wird zwischengespeichert, nur für den Ernstfall.
Nun zum Problem selbst:
Klicke ich den Commansdbutton einmal wird punkt 1 bis 3 anstandslos ausgeführt. Klicke ich diesen Button aber nochmals passiert folgendes. Das Eigentliche Dokument wird gespeichert. Dein Script wird aktiv und fragt nach überschreiben ja/nein. Das Script das für die Datenbank zuständig ist meldet "Datensatz schon vorhanden" und verhindert somit ein Überschreiben, (so sollte es auch sein). Klicke ich in Deinem Script bei der Abfrage ja/nein auf ja wird die neu Mappe überschrieben, und der Datensatz bleibt wie er ist, also ist es durchaus möglich das es 2 Versionen eines Datensatzes gibt.
Nun die Frage zu diesem Problem:
Kann mein Script so angepasst werden das es auch eine ja/nein Abfrage stellt und bei ja den Datensatz überschreibt?
Ich wollte die erstellte Mappe im jetzigen Zustand hochladen, geht aber nicht wegen der Dateigröße 2641KB, ist diese Größe eigentlich normal?
Sofern ich Dir jetzt nicht auf die Nerven gehe hätte ich da noch eine kleine
Da ich in meiner Mappe doch oft das Datum eingeben oder ändern muss würde ich gerne das Werkzeug OlkDateControll einfügen, also eine Kalenderfunktion die per klick das ausgewählte Datum einfügt, nur weis ich nicht wie ich das anstellen soll.
ich bedanke mich und wünsche einen angenehmen Tag
kiko

 

Hi,

ich hoffe, ich habe jetzt alles richtig verstanden.

Code:

Private Sub Daten_in_Tabelle_Click()
    Dim WS As Worksheet, WSRechnung As Worksheet, WB As Workbook
    Dim loLetzte As Long
    Dim fsO
    Dim Pfad As String
    Pfad = ThisWorkbook.Path & Application.PathSeparator & "" & Range("M1").Text & Range("T1").Text & "_AU" & ".xlsx"
    Pfad = Replace(Pfad, "/", "_")
    Set WS = ThisWorkbook.Worksheets("Auftrag")
    Set WSRechnung = ThisWorkbook.Worksheets("Rechnung")
    Set fsO = CreateObject("Scripting.FileSystemObject")
    If fsO.fileexists(Pfad) Then
        strabfrage = MsgBox("Soll die vorhandene Arbeitsmappe " & Pfad & " überschrieben werden", vbYesNo)
        If strabfrage = vbNo Then GoTo Daten_speichern
    End If
    Application.ScreenUpdating = False
    WS.Cells.Copy
    Set WB = Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    WB.SaveAs Pfad
    Application.DisplayAlerts = True
    WB.Close
    Application.ScreenUpdating = True
Daten_speichern:
    With WSRechnung
        .Unprotect "Passwort"
        loLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        For loZeile = 2 To loLetzte
            If .Cells(loZeile, 9) = WS.Range("D3") Then
                strabfrage = MsgBox("Soll der vorhandene Datensatz überschrieben werden", vbYesNo)
                If strabfrage = vbNo Then Exit Sub
                loZeile = loLetzte
                Exit For
            End If
        Next loZeile
        ' Werte eintragen
        .Cells(loZeile, 1) = WS.Range("M1") 'ReNr
        .Cells(loZeile, 2) = WS.Range("P1") 'ReJahr
        .Cells(loZeile, 3) = WS.Range("U1") 'erstellt am
        .Cells(loZeile, 5) = WS.Range("A15") 'Ausführungsdatum
        .Cells(loZeile, 6) = WS.Range("L15") 'Zeit von
        .Cells(loZeile, 7) = WS.Range("R15") 'Zeit bis
        .Cells(loZeile, 8) = WS.Range("S49") 'ausgeführt am
        .Cells(loZeile, 9) = WS.Range("D3") 'Kundennummer
        .Cells(loZeile, 10) = WS.Range("H3") 'Telefon Kunde
        .Cells(loZeile, 11) = WS.Range("D4") 'Titel Kunde
        .Cells(loZeile, 12) = WS.Range("D5") 'Name1
        .Cells(loZeile, 13) = WS.Range("D6") 'Name2
        .Cells(loZeile, 14) = WS.Range("D7") 'Straße
        .Cells(loZeile, 15) = WS.Range("D8") 'Ort
        .Cells(loZeile, 16) = WS.Range("O6") 'Personalnummer1
        .Cells(loZeile, 17) = WS.Range("R6") 'Name Pers1
        .Cells(loZeile, 18) = WS.Range("AA6") 'Stunden Pers1
        .Cells(loZeile, 19) = WS.Range("O7") 'Personalnummer2
        .Cells(loZeile, 20) = WS.Range("R7") 'Name Pers2
        .Cells(loZeile, 21) = WS.Range("AA7") 'Stunden Pers2
        .Cells(loZeile, 22) = WS.Range("O8") 'Personalnummer3
        .Cells(loZeile, 23) = WS.Range("R8") 'Name Pers3
        .Cells(loZeile, 24) = WS.Range("AA8") 'Stunden Pers3
        .Cells(loZeile, 25) = WS.Range("O9") 'Personalnummer4
        .Cells(loZeile, 26) = WS.Range("R9") 'Name Pers4
        .Cells(loZeile, 27) = WS.Range("AA9") 'Stunden Pers2
        .Cells(loZeile, 28) = WS.Range("AA10") 'Summe Stunden
        .Cells(loZeile, 29) = WS.Range("D12") 'Titel Ansprechpartner
        .Cells(loZeile, 30) = WS.Range("F12") 'Name Ansprechpartner
        .Cells(loZeile, 31) = WS.Range("D13") 'Telefon Ansprechpartner
        .Cells(loZeile, 32) = WS.Range("R12") 'Titel Auftrag erteilt
        .Cells(loZeile, 33) = WS.Range("T12") 'Name Auftrag erteilt
        .Cells(loZeile, 34) = WS.Range("R13") 'Telefon Auftrag erteilt
        '.Cells(lozeile, 35) = ws.Range("I49") 'Ja Auftrag erledigt
        '.Cells(lozeile, 36) = ws.Range("M49") 'nein Auftrag nicht erledigt
        .Cells(loZeile, 37) = WS.Range("R3") 'Auftragsort
        .Cells(loZeile, 38) = WS.Range("A17") 'Auftragsbeschreibnung
        '.Cells(lozeile, 39) = ws.Range("A20") 'Arbeitsbericht
        '.Cells(lozeile, 40) = ws.Range("A37") 'Materialbedarf
        .Select
        .Protect "Passwort"
    End With
    ThisWorkbook.Save
End Sub

Zur Frage mit dem Eintragen eines Datums: wenn es es aktuelle Datum ist, dann geht das am einfachsten mit Strg+. (Punkt). Andernfalls kannst du das mit einem Kalendersteuerelement aus den ActiveX-Steuerelementen machen. Bei einem Doppelklick auf eine Zelle wird es aufgerufen und das dort ausgewählte Datum dann in diese Zelle geschrieben, das Steuerelement wird im Anschluss daran wieder verborgen. Bei erneutem Doppelklick auf die Zelle kann es auch ohne Eintrag wieder verborgen werden.

Code:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
    Calendar1.Top = ActiveCell.Offset(1, 0).Top
    Calendar1.Left = ActiveCell.Offset(1, 1).Left
    Calendar1.Visible = Not Calendar1.Visible
End Sub
Private Sub Calendar1_Click()
    ActiveCell = Calendar1
    ActiveCell.NumberFormat = "m/d/yyyy"
    Calendar1.Visible = False
End Sub

 

Moin Beverly,
Das ganze ist mir nun schon ein wenig peinlich, denn es funktioniert nicht. Ich versuche mal in Kurzform den Soll/Ist-Zustand, Schrittweise zu beschreiben. Das alles ist auf das Auftragsformular anzuwenden.
Istzustand ohne das neue Script:
1) Click auf neuer Auftrag, (Auftragsnummer wird um 1 hochgezählt von 00001 auf 00002) bedarf keiner Änderung.
2) Click auf Kunde eintragen beadarf keiner Änderung
3) Click auf Mitarbeiter eintragen, bedarf keiner Änderung
4) Click auf speichern, Datensatz wird eingetragen unter 00002, Mappe wird erstellet unter 00002_Au, Aktive Mappe wird zwischengespeichert.An diesem Punkt stelle ich fest das ich eine falsche Eingabe gemacht habe und möchte diese noch verändern und speichern. es passiert folgendes.
4.1) Click auf speichern, (Warnung; Datensatz 00002 ist schon vorhanden, also es findet kein Eintrag statt).Die neue Mappe wird aktuell überschrieben mit der Nummer 00002_Au, Aktive Mappe wird zwischengespeichert.
Nun besteht zwischen der Mappe 00002_Au und dem Datensatz 00002 ein unterschied der nicht sein darf.
Für den neuen Datensatz folgen Punkt 1bis 4)
-----------------------------
Istzustand mit dem neuen Script
1)2)3) wie oben
4) Click auf speichern, Datensatz wird eingetragen unter 00002, Mappe wird erstellet unter 00002_Au, Aktive Mappe wird zwischengespeichert.An diesem Punkt stelle ich fest das ich eine falsche Eingabe gemacht habe und möchte diese noch verändern und speichern. es passiert folgendes.
4.1) Click auf speichern, (Warnung; Mappe ist schon vorhanden, überschreiben ja/nein), Warnung: Datensatz ist schon vorhanden, überschreiben ja/nein. Ich sage ja und der Datensatz wird mit der Änderung überschrieben.
4.2) Nun folgt ein neuer Auftrag mit der nächsten Nummer, also 00003_Au. Ich speichere und es wird eine neue Mappe 00003 erstellt ohne Warnung (Diese Mappe gibt es ja auch noch nicht) Jetzt folgt die Abfrage Deines Scriptes mit Ja/nein, ich sage nein und es wird kein Datensatz eingetragen, es sollte aber ein Datensatz 00003 geben, ich sage ja und der Datensatz 00002 wird auf 00003 überschrieben, also gibt es Datensatz 00002 nicht mehr.Mache ich so weiter, sagen wir 10 mal, habe ich 10 neue Mappen aber nur 2 Datensätze.
------------------------
Was die Dateigröße angeht, so vermute ich das hier das Formatieren der Zellen Schuld hatte. Ich habe eine neue Mappe erstellt die lediglich 80Kb groß ist. Ich werde diese Mappe mal versuchen hochzuladen. In dieser Mappe ist der Button Commandbutton mit dem neuen script.
------------------------
Was die Kalenderfunktion angeht so kann ich die Schritte leider nicht nachvollziehen, mir fehlen einfach die Kenntnisse. Ich schaffe es nicht das ich in der Zelle A15 oder S49 im Auftrag diese Funktion eintragen soll.
Wenn Du nun das Handtuch wirfst verstehe ich das, dennoch vielen Dank für Deine Hilfe die weit über das Maß an Hilfe hinausgeganegen ist.

 

Hi,

es muss dir ganz und gar nicht peinlich sein. Das Problem beim schriftlichen Fragestellen und Antworten ist nun mal, dass man den Gegenüber häufig nicht 100%ig versteht und dann kommt es zu Rückfragen. Aus diesem Grund von mir die Bitte, beschreibe doch noch mal ganz genau Schritt für Schritt, wie der Ablauf für das Erfassen der Aufträge ablaufen soll, denn ich habe nur entehmen können, wie es nicht sein soll.

Zur Kalenderfunktion: gehe auf das Register Entwicklertools -> Befehlsgruppe: Steuerelemente -> Schalter: Einfügen -> ActiveX-Steuerelemente. Dort findest du unten rechts "..." und wenn du darauf klickst, werden weitere Elemente angezeigt. Markiere "Kalendersteuerelement 12.0" -> OK, gehe in die Tabelle und ziehe das Element bei gedrückter Maustaste auf die entsprechende Größe. Mache dann einen Doppelklick auf das Element und kopiere den Code ins Codefenster. Schalte dann in der Behfehlsgruppe Steuerelemente den Entwurfsmodus aus (Klick auf den Schalter). Wenn du nun in dem Kalender auf ein Datum klickst, steht es in der Zelle, in der zuvor der Cursor stand. Ich habe mal ein fertiges Beispiel angehängt.

 

Danke für Deine Geduld..
Dein Anhang habe ich runtergeladen, jedoch ist es lediglich eine Tabelle, werde mich aber nochmal dahinterklemmen. Fehlermeldung Projekt oder Bibliothek nicht gefunden.
Speichern:
es sollte ein erfasster Datensatz
1)in die Tabelle eingetragen werden mit einer Prüfung ob dieser Datensatz schon vorhanden ist
2)eine neue Mappe ertsellen, als Titel die Auftragsnummer, auch hier eine Prüfung ob diese Mappe schon vorhanden ist
3) die eigentliche Auftragsmappe zwischenspeichern
zu 1 und 2) überschreiben bestätigen, (alternativ überschreiben verhindern, halte ich im Moment für Sinnvoll, denn ich habe ja das Stornoformular.) Wenn ein überschreiben möglich ist, so sollte das für beide Einträge (Mappe und Datensatz gelten ohne das ein Anwender 1 mal ja und einmal nein bestätigen kann. Diese regel sollte immer für den aktuellen Datensatz gelten.
4) Anlegen eines neuen Datensatz mit vortlaufender Nummer, hierbei wird im Rechnungsblatt die letzte Auftragsnummer ausgelesen und 1Zähler addiert. Nun folgen die Schritte wie oben beschrieben. Im Datenblatt, als auch im Verzeichniuss der neuen Mappe finden sich dann fortlaufende Nummern 00001,00002,00003 usw.
Sofern es nötig sein sollte könnte man ja mal telefonieren, Nummer sende ich Dir auf Anfrage unter kiko63505@freenet gerne zu.

viele Grüße
Kiko mit .....:nixwissen

 

Hi,

noch ein Versuch, dann versuchen wir es mit telefonieren.

Code:

Private Sub CommandButton1_Click()
    Dim WS As Worksheet, WSRechnung As Worksheet, WB As Workbook
    Dim loLetzte As Long
    Dim boAction As Boolean
    Dim Pfad As String
    Dim strAbfrage As Variant
    Pfad = ThisWorkbook.Path & Application.PathSeparator & "" & Range("M1").Text & Range("T1").Text & "_AU" & ".xlsx"
    Pfad = Replace(Pfad, "/", "_")
    Set WS = ThisWorkbook.Worksheets("Auftrag")
    Set WSRechnung = ThisWorkbook.Worksheets("Rechnung")
    Application.ScreenUpdating = False
    With WSRechnung
        '.Unprotect "Passwort"
        loLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        For loZeile = 2 To loLetzte
            If .Cells(loZeile, 1) = WS.Range("M1") Then
                strAbfrage = MsgBox("Soll der vorhandene Datensatz überschrieben werden", vbYesNo)
                If strAbfrage = vbNo Then
                    Exit Sub
                Else
                    boAction = True
                    Exit For
                End If
           End If
        Next loZeile
        If boAction = False Then
            WS.Range("M1") = .Cells(loLetzte, 1) + 1
            loZeile = loLetzte + 1
        End If
        ' Werte eintragen
        .Cells(loZeile, 1) = WS.Range("M1") 'ReNr
        .Cells(loZeile, 2) = WS.Range("P1") 'ReJahr
        .Cells(loZeile, 3) = WS.Range("U1") 'erstellt am
        .Cells(loZeile, 5) = WS.Range("A15") 'Ausführungsdatum
        .Cells(loZeile, 6) = WS.Range("L15") 'Zeit von
        .Cells(loZeile, 7) = WS.Range("R15") 'Zeit bis
        .Cells(loZeile, 8) = WS.Range("S49") 'ausgeführt am
        .Cells(loZeile, 9) = WS.Range("D3") 'Kundennummer
        .Cells(loZeile, 10) = WS.Range("H3") 'Telefon Kunde
        .Cells(loZeile, 11) = WS.Range("D4") 'Titel Kunde
        .Cells(loZeile, 12) = WS.Range("D5") 'Name1
        .Cells(loZeile, 13) = WS.Range("D6") 'Name2
        .Cells(loZeile, 14) = WS.Range("D7") 'Straße
        .Cells(loZeile, 15) = WS.Range("D8") 'Ort
        .Cells(loZeile, 16) = WS.Range("O6") 'Personalnummer1
        .Cells(loZeile, 17) = WS.Range("R6") 'Name Pers1
        .Cells(loZeile, 18) = WS.Range("AA6") 'Stunden Pers1
        .Cells(loZeile, 19) = WS.Range("O7") 'Personalnummer2
        .Cells(loZeile, 20) = WS.Range("R7") 'Name Pers2
        .Cells(loZeile, 21) = WS.Range("AA7") 'Stunden Pers2
        .Cells(loZeile, 22) = WS.Range("O8") 'Personalnummer3
        .Cells(loZeile, 23) = WS.Range("R8") 'Name Pers3
        .Cells(loZeile, 24) = WS.Range("AA8") 'Stunden Pers3
        .Cells(loZeile, 25) = WS.Range("O9") 'Personalnummer4
        .Cells(loZeile, 26) = WS.Range("R9") 'Name Pers4
        .Cells(loZeile, 27) = WS.Range("AA9") 'Stunden Pers2
        .Cells(loZeile, 28) = WS.Range("AA10") 'Summe Stunden
        .Cells(loZeile, 29) = WS.Range("D12") 'Titel Ansprechpartner
        .Cells(loZeile, 30) = WS.Range("F12") 'Name Ansprechpartner
        .Cells(loZeile, 31) = WS.Range("D13") 'Telefon Ansprechpartner
        .Cells(loZeile, 32) = WS.Range("R12") 'Titel Auftrag erteilt
        .Cells(loZeile, 33) = WS.Range("T12") 'Name Auftrag erteilt
        .Cells(loZeile, 34) = WS.Range("R13") 'Telefon Auftrag erteilt
        .Cells(loZeile, 35) = WS.Range("I49") 'Ja Auftrag erledigt
        .Cells(loZeile, 36) = WS.Range("M49") 'nein Auftrag nicht erledigt
        .Cells(loZeile, 37) = WS.Range("R3") 'Auftragsort
        .Cells(loZeile, 38) = WS.Range("A17") 'Auftragsbeschreibnung
        .Cells(loZeile, 39) = WS.Range("A20") 'Arbeitsbericht
        .Cells(loZeile, 40) = WS.Range("A37") 'Materialbedarf
        .Select
        '.Protect "Passwort"
    End With
    ThisWorkbook.Save
    WS.Cells.Copy
    Set WB = Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    WB.SaveAs Pfad
    Application.DisplayAlerts = True
    WB.Close
    Application.ScreenUpdating = True
End Sub

Kalendersteuerelement: gehe im VBA-Editor auf Extras -> Verweise und wähle dort "Microsoft Calendar Control 2007" aus, dann sollte es funktionieren.

 

Hallo beverly...
nach den ersten Tests muss ich sagen es funktioniert alles wie ich es mir vorstellte. Eventuelle Schwachstellen werden erst sichtbar wenn die Mappe im täglichen Einsatz sein sollte. Nicht zwingende Änderung könnte im speichern als Neue Mappe, welche mit 3 Arbeitsblättern gespeichert wird, eines würde langen. Was den Blattschutz im Rechnungsblatt angeht, so würde ich gerne die erste Spalte als "Clickmich" Spalte benutzen. Also als Spalte die ich anklicke um einen Datensatz zu laden, alle anderen Zellen sollen gesperrt werden. Was muss ich im folgenden Code ändern damit die Abfrage nach der letzten Nummer in Spallte B stattfindet?
Private Sub Neuer_Auftrag_Click()'
Zellen leeren und die Auftragsnummer um 1 erhöhen
Dim A() As String, i As Long, Zelle As Range
A = Split("AK22,----0,A37", ",")
For i = LBound(A) To UBound(A)
For Each Zelle In Range(A(i)).Cells
Zelle.MergeArea.ClearContents
Next Zelle
Next i

With Sheets("Rechnung")
Range("M1").Value = WorksheetFunction.Max(.Range("A1:A" & .Range("A65536").End(xlUp).Row).Value) + 1
End With
'ActiveSheet.Protect "1"

End Sub
Kalenderfunktion:
An dem genanten Ort im Editor habe ich schon seit 3 Tagen gesucht, es gibt dort keinen gleichlautenden oder auch nur annähernd änlichen Eintrag. Kann das bedeuten das ich auf diese Funktion nicht zugreifen kann? Ist diese Funktion möglicherweise gesperrt für meine Officefunktion? Ich habe die Schülerversion... warum auch nicht, zumal beide Kiddis mit Office arbeiten.

An dieser Stelle möchte ich nochmals betonen das ich ohne Deine Hilfe dieses Problem nich in Griff bekommen hätte....
Danke
Kiko

 

Hi,

es gibt 2 Möglichkeiten, nur 1 Tabelle in der neuen Arbeitsmappe zu erzeugen: 1. die überschüssigen Tabellenblätter nach dem Erstellen der Arbeitsmappe zu löschen, oder eine Arbeitsmappe mit nur einem Tabellenblatt zu erstellen. Wenn du die letzte Variante anwenden willst, dann kannst du diesen Code verwenden (ich habe hier nur die letzten Zeilen des Gesamtcodes eingestellt, da sich diese nicht ändern. Du musst nur am Anfang noch eine Variable deklarieren Dim inAnzahl As Integer)

Code:

    ThisWorkbook.Save
    WS.Cells.Copy
    inAnzahl = Application.SheetsInNewWorkbook
    If inAnzahl <> 1 Then
        Application.SheetsInNewWorkbook = 1
    End If
    Set WB = Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Application.DisplayAlerts = False
    WB.SaveAs Pfad
    Application.DisplayAlerts = True
    WB.Close
    Application.SheetsInNewWorkbook = inAnzahl
    Application.ScreenUpdating = True

Um Spalte B als "Click mich" zu verwenden musst du nur in dieser Zeile

Code:

 Range("M1").Value = WorksheetFunction.Max(.Range("A1:A" & .Range("A65536").End(xlUp).Row).Value) + 1

das A durch ein B ersetzen.

Was das Kalendersteuerelement betrifft, kann ich leider nicht sagen, ob es das in deiner Version gibt, denn ich habe die Office Pro Version, ist aber durchaus möglich. Wenn du es unter den zusätzlichen AxtiveX-Steuerelementen nicht findest (Kalender-Steuerelement 2007), dann gibt es das offensichtlich nicht. Schau dann mal nach "Microsoft MonthView Control 6.0 (SP6)", das kann man auf ähnliche Weise verwenden.

 

Hi,

nochmal zur Frage Kalender-Steuerelement: hast du Office komplett installiert?

Der Verweis heißt genau "Microsoft Calendar Control 2007" und sollte eigentlich vorhanden und automatisch aktiviert sein, wenn ein solches Objekt mit Code in der Arbeitsmappe vorhanden ist. Es müsste eigentlich auch unter den zusätzlichen ActiveX-Steuerelementen zu finden sein, wo es aber "Kalender-Steuerelement 12.0" heißt.