Tabllen in Datei speichern nur Feste werte!

Hallo liebe EXCELgemeinde.
Ich habe eine Datei ( Konfigurator) .xlt mit ca 15 Tabellen, aus dennen ich 2x je 6 Tabellen in eine neue Datei inkl. aller Formatierungen und Werte speichern möchte.
Ohne Formlen, Makros und nicht veränderbar.
Die Tabellen sind Blatt geschütz und sollen wieder geschütz werden.
Speicherung soll unter variablem Namen aus einer Zell und Datum auf Laufwerk c:\ als .xls-Datei erfolgen
Einige Zellen in der Original Datei (Konfigurator) sind zur Eingabe zu gelassen.- diese sollen nach dem Speichern nun geschütz und nicht Änderbar sein. (Hierunter befinden sich auch Felder mit bestimmten Gültigkeiten.).
Wie kann ich dies über einen Command Button erledigen.
Zusätzlich soll das aktuelle Datum und der Benutzernam auf einer bestimmten Tabelle aus diesen funktionenn aufgezeichnet werden.


Function BenutzerName()
'Funktion Benutzername
BenutzerName = Application.UserName
End Function


Function FileDate()
'Funktion File Datum
FileDate = FileDateTime(ThisWorkbook.FullName)
End Function

Ich hoffe es kann mir jemand eine Vorschlag machen. Ich habe bereits tausende von hier im Forum genutzen Lösungen probiert aber leider reichen meien Kenntniss hierfü nicht.
Vielen Dank im Voraus.
Ralph
PS: Ich werde leider erst heute gegen 20 Uhr wieder Antworten können.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

ThisWorkbook.Activate quellbuch = ThisWorkbook.Name nameneu = Sheets("Tabelle2").Cells(1, 1) & " " & Date Sheets(Array("Tabelle1", "Tabelle2")).Select Sheets(Array("Tabelle1", "Tabelle2")).Copy ThisWorkbook.Activate quellbuch = ThisWorkbook.Name nameneu = Sheets("Tabelle2").Cells(1, 1) & " " & Date Sheets(Array("Tabelle1", "Tabelle2")).Select Sheets(Array("Tabelle1", "Tabelle2")).Copy For s = 1 To Sheets.Count Sheets(s).Unprotect Password:="xy" Sheets(s).Select Range(Range("A1"), ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _ Transpose:=False Range("A1").Select Sheets(s).Protect Password:="xy" Next ActiveWorkbook.SaveAs Filename:="C:\" & nameneu & ".xls" Windows(quellbuch).Activate Sheets(Array("Tabelle1")).Select

Sub kopieren() Dim NameNeu As String 'die Mappe in der das Makro steht aktivieren ThisWorkbook.Activate 'neuer Mappenname = Zellinhalt von AU3 und Leerzeichen und Datum NameNeu = Sheets(1).Range("AU3").Value & " " & Date & ".xls" 'Neue Mappe wird erstellt und Blätter 1 - 6 eingefügt (Wert entsprechend anpassbar) Sheets(Array(1, 2, 3, 4, 5, 6)).Copy Sheets(1).Range("A50") = "C:\" & NameNeu & ".xls" 'kompletter neue Name Sheets(1).Range("A51") = Date ' Datum Sheets(1).Range("A52") = Application.UserName 'Benutzername For s = 1 To Sheets.Count Sheets(s).Select 'nacheinander die Blätter abarbeiten 'die nächsten Zeilen kopieren den genutzten Bereich und fügen nur die Werte wieder ein Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _ Transpose:=False Range("A1").Select 'verhindert das auswählen aber funktioniert nicht wenn erneut geöffnet wird Sheets(s).EnableSelection = xlNoSelection 'anstatt "kennwort" das gewüschte eintragen Sheets(s).Protect Password:="kennwort", Scenarios:=True, UserInterfaceOnly:=True Next Sheets(1).Select ActiveWorkbook.SaveAs Filename:="C:\" & NameNeu 'Mappe speichern ActiveWorkbook.Close 'neue Mappe schließen End Sub

Private Sub Worksheet_Change(ByVal Target As range) ' Wenn AI13=7 (Multipolstecker) dann Macro LöscheEinAus If Target.Count = 1 Then If Target.Address = "$AI$13" And Target.Value = 7 Then Application.EnableEvents = False Call LöscheEinAusModule Application.EnableEvents = True End If ' erstellt von Hajo.Ziplies@web.de 16.08.03 ' alle Buchstaben Groß in einem bestimmten Bereich Dim RaBereich As range, RaZelle As range Application.EnableEvents = False ' Bereich der Wirksamkeit Set RaBereich = range("AO13:BM13") ' ActiveSheet.Unprotect Application.EnableEvents = False For Each RaZelle In range(Target.Address) If Not Intersect(RaZelle, RaBereich) Is Nothing Then RaZelle.Value = UCase(RaZelle.Value) End If Next RaZelle Application.EnableEvents = True ' ActiveSheet.protect Set RaBereich = Nothing End If End Sub

Sub kopieren() Dim NameNeu As String Application.EnableEvents = False 'verhindern, das ChangeEreignis aufgerufen wird 'die Mappe in der das Makro steht aktivieren ThisWorkbook.Activate 'neuer Mappenname = Zellinhalt von AU3 und Leerzeichen und Datum NameNeu = Sheets(1).Range("AU3").Value & " " & Date & ".xls" 'Neue Mappe wird erstellt und Blätter 1 - 6 eingefügt (Wert entsprechend anpassbar) Sheets(Array(1, 2, 3, 4, 5, 6)).Copy Sheets(1).Range("A50") = "C:\" & NameNeu & ".xls" 'kompletter neue Name Sheets(1).Range("A51") = Date ' Datum Sheets(1).Range("A52") = Application.UserName 'Benutzername For s = 1 To Sheets.Count Sheets(s).Select 'nacheinander die Blätter abarbeiten 'die nächsten Zeilen kopieren den genutzten Bereich und fügen nur die Werte wieder ein Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _ Transpose:=False Selection.Locked = True 'Zellen im ausgewählten Bereich schützen Range("A1").Select 'Alle Buttons löschen For Each b In Sheets(s).Buttons b.Delete Next 'verhindert das auswählen aber funktioniert nicht wenn erneut geöffnet wird Sheets(s).EnableSelection = xlNoSelection 'anstatt "kennwort" das gewüschte eintragen Sheets(s).Protect Password:="kennwort", Scenarios:=True, UserInterfaceOnly:=True Next Sheets(1).Select ActiveWorkbook.SaveAs Filename:="C:\" & NameNeu 'Mappe speichern ActiveWorkbook.Close 'neue Mappe schließen Application.EnableEvents = True 'Option wieder aktivieren End Sub

Sub kopieren() Dim NameNeu As String Application.EnableEvents = False 'verhindern, das ChangeEreignis aufgerufen wird 'die Mappe in der das Makro steht aktivieren ThisWorkbook.Activate 'neuer Mappenname = Zellinhalt von AU3 und Leerzeichen und Datum NameNeu = Sheets(2).range("AU3").Value & "_" & Date & ".xls" 'Neue Mappe wird erstellt und Blätter 2 - 6 eingefügt (Wert entsprechend anpassbar) Sheets(Array(2, 3, 4, 5, 6)).Copy ' Blattschutz aufheben For s = 1 To Sheets.Count Sheets(s).Select Sheets(s).Unprotect Password:="KENNWORT" Next Sheets(1).range("A50") = NameNeu & ".xls" 'kompletter neue Name Sheets(1).range("A51") = Date ' Datum Sheets(1).range("A52") = Application.UserName 'Benutzername For t = 1 To Sheets.Count Sheets(t).Select 'nacheinander die Blätter abarbeiten 'die nächsten Zeilen kopieren den genutzten Bereich und fügen nur die Werte wieder ein range("A1", ActiveCell.SpecialCells(xlLastCell)).Select Selection.Copy range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, _ Transpose:=False Selection.Locked = True 'Zellen im ausgewählten Bereich schützen range("A1").Select 'Alle Buttons löschen For Each b In Sheets(t).Buttons b.Delete Next 'verhindert das auswählen aber funktioniert nicht wenn erneut geöffnet wird Sheets(t).EnableSelection = xlNoSelection 'anstatt "kennwort" das gewüschte eintragen Sheets(t).Protect Password:="KENNWORT", Scenarios:=True, UserInterfaceOnly:=True Next Sheets(1).Select 'Einbelenden des Speichern unter dialogs Application.Dialogs(xlDialogSaveAs).Show (strPfad) & (NameNeu) 'ActiveWorkbook.SaveAs Filename:="D:\" & NameNeu 'Mappe speichern 'ActiveWorkbook.Close 'neue Mappe schließen Application.EnableEvents = True 'Option wieder aktivieren End Sub

das nachfolgende sieht ziemlich chaotisch aus und für excel vba profis ist das sicher auch zum hände übern kopf schlagen aber ich weiß grad net, wie man es besser lösen sollte ^^
- bei mir funktioniert das mit dem namen auch dann, wenn der Bereich AU3:BE3 verbunden ist.
Klick am besten mal auf die Zelle und schau nochmal, was da oben links als zellname angezeigt wird.
- Die Commandbuttons und Kontrollkästchen werden zwar mitkopiert aber sollten normal in der neuen Mappe gelsöcht werden.
schau mal ob das besser funktioniert ^^
sollte dasMakro mittendrin stoppen, führe einmal das hier aus, damit etwaige Bildschirmmeldungen etc wieder angezeigt werden.


Sub meldungenzeigen()
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Falls es nicht funktioniert auf debuggen klicken und mir sagen, an welcher stelle es hängen bleibt.
Bei mir funktioniert immer alles aber ich weiß auch ncht, was alles in deiner Datei enthalten ist und evtll stört.


Sub kopieren()
Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False
nameneu = Sheets(1).Range("AU3").Value & " " & Date
qb = Array(2, 3, 4, 5, 6)  'Die zu kopierenden Seiten
ab = UBound(qb) 'Anzahl Blätter von qb ermitteln
Workbooks.Add
neubuch = ActiveWorkbook.Name
fb = ab - Workbooks(neubuch).Sheets.Count + 1 'fehlende Blätter
For n = 1 To fb
Workbooks(neubuch).Sheets.Add
Next
For i = 1 To Sheets.Count
Sheets(i).Name = i
Next
For s = 0 To UBound(qb)
Debug.Print s
ThisWorkbook.Sheets(qb(s)).Range("A:IV").Copy
Workbooks(neubuch).Sheets(s + 1).Select
Range("A1").PasteSpecial
Range("A1", ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False,  _
Transpose:=False
Selection.Locked = True
ActiveSheet.Buttons.Delete
ActiveSheet.CheckBoxes.Delete
Range("A1").Select
ActiveSheet.Name = ThisWorkbook.Sheets(qb(s)).Name
ActiveSheet.Protect Password:="kennwort", Scenarios:=True, UserInterfaceOnly:=True
Next
Sheets(1).Select
Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True
ActiveWorkbook.SaveAs Filename:="C:\" & nameneu & ".xls" 'Mappe speichern
End Sub

Beliebteste Forumthreads (12 Monate)

Tabllen in Datei speichern nur Feste werte!

16 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

16
Beiträge zum Forumthread

Beiträge zu diesem Forumthread