Tabellen abspeichern durch Dropdownlisten

24/11/2009 - 10:40 von schmalen | Report spam
Hallo zusammen,
Ich baue gerade eine Tabelle zusammen und habe folgendes Problem.
In der Tabelle 1 (Linie1) habe ich einen Fragebogen entworfen (A1 bis E115)
In F1 ist eine Dropdownliste vorhanden, diese ist mit einzelnen Namen
hinterlegt, die ich in Tabelle2 (Maschinen in B2 bis B10) hinterlegt habe.

Nun möchte ich eine Art Automatisierung schaffen, das heißt, nach dem ich
nun das Formular ausgefüllt habe, und in der Dropdownliste meine Maschine
auswàhle, soll eine Abspeicherung also ein neues Tabellenblatt mit diesen
Maschinennamen aus der Dropdownliste erstellt werden, es soll auch zumindest
eine Art Sicherheitsabfrage vorkommen z.B. ( Wirklich abspeichern etc… ?), es
kann ja vorkommen in der Hektik das man eine falsche Maschine ausgewàhlt hat
und somit überschrieben würde.

Gruß
Andreas
 

Lesen sie die antworten

#1 Andreas Killer
24/11/2009 - 11:59 | Warnen spam
schmalen schrieb:

Nun möchte ich eine Art Automatisierung schaffen, das heißt, nach dem ich
nun das Formular ausgefüllt habe, und in der Dropdownliste meine Maschine
auswàhle, soll eine Abspeicherung also ein neues Tabellenblatt mit diesen


Hmm, jedesmal wenn eine Maschine ausgewàhlt wird soll die Abfrage kommen?

Nicht das Problem, überwache im Worksheet_Change-Ereignis die
Dropdown-Zelle und rufe dann ggf. Deine Speicher-Routine auf.

Ich schenk mir mal ein Beispiel, ich vermute das Du weißt wie das geht!?!

Maschinennamen aus der Dropdownliste erstellt werden, es soll auch zumindest
eine Art Sicherheitsabfrage vorkommen z.B. ( Wirklich abspeichern etc… ?), es
kann ja vorkommen in der Hektik das man eine falsche Maschine ausgewàhlt hat
und somit überschrieben würde.


MsgBox ist eine Function die die gewàhlte Antwort zurückgibt und diese
kann man auswerten. Beim Abspeichern in einem Blatt kann es aber
durchaus zu div. Situationen kommen, dazu mache ich mal ein Beispiel.

Andreas.

Option Explicit

Sub Test()
Dim Antwort As VbMsgBoxResult, Linie As String, Maschine As _
String, BlattName As String

'Testnamen
Linie = "Linie1"
Maschine = "Maschine5"
BlattName = ValidSheetName(Linie & "-" & Maschine)

Antwort = MsgBox("Soll die " & Linie & " mit der " & _
Maschine & " im Tabellenblatt " & BlattName & " " & _
"gespeichert werden?", vbYesNo + vbInformation, "")
Select Case Antwort
Case vbYes
'Ja, wirklich speichern
TestSheet:
'Blatt schon da?
If SheetExists(BlattName) Then
Antwort = MsgBox("Tabellenblatt " & BlattName & _
" existiert bereits! Überschreiben?", _
vbYesNoCancel + vbExclamation, "")
Select Case Antwort
Case vbYes
'Okay, alles gut, überschreiben
Case vbNo
'Nö, neues Blatt anlegen?
BlattName = InputBox("Wie soll die Alternaive " & _
"Tabelle heißen?", "", NewSheetName(BlattName))
If Len(BlattName) = 0 Then Exit Sub
'Prüfen ob es das Blatt gibt
GoTo TestSheet
Case vbCancel
'Abbruch
Exit Sub
End Select
End If
SpeicherMaschine BlattName, Linie, Maschine
Case vbNo
'Denn eben nich. :-)
End Select
End Sub

Sub SpeicherMaschine(BlattName, Linie, Maschine)
'Speichert die Daten ab
Dim WS As Worksheet
'Tabelle am Ende anlegen
Set WS = Sheets.Add(After:=Sheets(Sheets.Count))
'Den Namen vergeben
WS.Name = BlattName
'etc.
End Sub

Private Function SheetExists(ByVal SheetName As String, _
Optional WB As Workbook = Nothing) As Boolean
'Prüft ob das Tabellenblatt SheetName existiert
Dim S As Worksheet
If WB Is Nothing Then Set WB = ActiveWorkbook
On Error GoTo ExitPoint
Set S = WB.Sheets(SheetName)
SheetExists = True
ExitPoint:
End Function

Private Function NewSheetName(ByVal SheetName As String) As _
String
'Gibt einen nicht existierenden Tabellenblattnamen zurück _
der mit SheetName beginnt
Dim I As Integer, NewName As String, SheetExt As String
SheetName = ValidSheetName(SheetName)
NewName = SheetName
If SheetExists(SheetName) Then
I = 0
Do
I = I + 1
SheetExt = " (" & I & ")"
If Len(SheetName) + Len(SheetExt) > 31 Then SheetName = _
Mid(SheetName, 1, 31 - Len(SheetExt))
NewName = SheetName & SheetExt
Loop Until Not SheetExists(NewName)
End If
NewSheetName = NewName
End Function

Function ValidSheetName(ByVal SheetName As String) As String
'Entfernt ungültige Zeichen aus Sheetname
Const InvalidChars = ":\/?*[]"
Dim I As Integer
For I = 1 To Len(InvalidChars)
SheetName = Replace(SheetName, Mid(InvalidChars, I, 1), "")
Next
ValidSheetName = Mid(SheetName, 1, 31)
End Function

Ähnliche fragen