speichern von Kopie

Sub copy1() Sheets("DV_Zeit").Select Sheets("DV_Zeit").copy ActiveWorkbook.Sheets("DV_Zeit").Select ActiveWorkbook.Sheets("DV_Zeit").Name = "PZB" ActiveWorkbook.UpdateLinks = xlUpdateLinksNever ChDir "G:\USER\PDL\PZB" ActiveWorkbook.SaveAs Filename:="G:\USER\PDL\PZB\PZB & ActiveWorkbook.Sheets("DV_Zeit").cells(2, 2).value.xls", FileFormat:= _ xlNormal , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False ActiveWindow.Close End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub copy1() Sheets("DV_Zeit").Select Sheets("DV_Zeit").copy ActiveWorkbook.Sheets("DV_Zeit").Select ActiveWorkbook.Sheets("DV_Zeit").Name = "PZB" ActiveWorkbook.UpdateLinks = xlUpdateLinksNever ChDir "G:\USER\PDL\PZB" ActiveWorkbook.SaveAs Filename:="G:\USER\PDL\PZB\" PZB & ActiveWorkbook.Sheets_("PZB").Cells(2, 2).Value & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False ActiveWindow.Close End Sub

Sub cosa() On Error Resume Next 'MsgBox "Wählen Sie das Zielverzeichnis." Dim aa As String Dim rue Dim fd As FileDialog Set fd = Application.FileDialog(msoFileDialogFolderPicker) With fd .Title = "Verzeichnisauswahl" End With If fd.Show = -1 Then If Mid(fd.SelectedItems(1) & "\", 4, 1) = "\" Then aa = fd.SelectedItems(1) Else aa = fd.SelectedItems(1) & "\" End If End If Dim iClick As Integer iClick = MsgBox( _ prompt:="Soll die folgende Datei gespeichert werden?" & Chr(13) & aa & ActiveWorkbook.Name & "_" & Format(Now, "YYMMDD_HHMMSS") & ".xls", _ Buttons:=vbYesNo, Title:="Bestätigung") If iClick = vbNo Then Exit Sub ElseIf iClick = vbYes Then ActiveWorkbook.SaveCopyAs Filename:=aa & ActiveWorkbook.Name & "_" & Format(Now, "YYMMDD_HHMMSS") & ".xls" End If End Sub

Also es sollen wirklich nur die Inhalte der Tabelle kopiert werden, ohne Makros, ohne verknüpfungen und ohne formeln. Dieses neue Workbook soll, quasie "unsichtbar" kopiert und gespeichert werden. die kopie soll auf Ziellaufwerk G:\User\PDL\PBZ mit dem neuem Namen "PBZ und dem Inahlt der Zelle B2" aus dem sheet gespeichert werden, ohne das der User, der das Workbook erstellt hat irgendwelche eingaben oder Bestätigungen machen muß. Wenn der User das Workbook speichert, soll quasie eine kopie der Tabelle ("DV_Zeit")aus dem Workbook, in den Ordner der PDL (Pflegedienstleitung)kopiert werden. Die PDL brauch auch nur dieses sheet, alles andere aus dem Workbook ist in diesem Fall für "USER PDL" unintressant.
Meinen Code zum speichern des Workbooks sieht so aus


Sub speichern()
ChDrive "G"
ChDir "G:\User\WB5\Bewohner\"
Dim I As Integer
Application.ScreenUpdating = False
For I = 1 To ActiveWorkbook.Worksheets.Count
Worksheets(I).Activate
ActiveWindow.DisplayHeadings = False
Next I
Application.ScreenUpdating = True
Sheets(1).Activate
Dim Dateiname
Dateiname = Application.GetSaveAsFilename(InitialFileName:="LN&PZB_" & ActiveWorkbook.Sheets("Name").Cells(12, 2).Value & "_" & _
ActiveWorkbook.Sheets("Name").Cells(15, 2).Value & "_" & ActiveWorkbook.Sheets("Name").Cells(16, 2) & ".bak", _
fileFilter:="alle Dateien (*.*), *.*")
If Dateiname <> False Then
Application.ScreenUpdating = False
Range("B22") = "Erhebung für" & " " & ActiveWorkbook.Sheets("Name").Cells(15, 2).Value & " " & "abgeschlossen"
Application.ScreenUpdating = True
ThisWorkbook.SaveAs Dateiname
MsgBox "Die Speicherung ist abgeschlossen"
End If
End Sub

Hilft das jetzt weiter?
Hoffentlich

Sub savkop() Application.ScreenUpdating = False Dim a As String Dim b As String Dim c As String Dim bk As Workbook a = ThisWorkbook.Name b = "PBZ" & Range("B2").Value Set bk = Workbooks.Add c = ActiveWorkbook.Name Windows(a).Activate Sheets("DV-Zeit").Select Sheets("DV-Zeit").Copy Before:=Workbooks(c).Sheets(1) Workbooks(c).Activate Application.DisplayAlerts = False Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3")).Select Sheets("Tabelle3").Activate ActiveWindow.SelectedSheets.Delete Application.DisplayAlerts = True Cells.Select Selection.Copy Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select Application.CutCopyMode = False ActiveWorkbook.SaveAs Filename:="G:\User\PDL\PBZ\PBZ_" & b & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False ActiveWindow.Close Application.ScreenUpdating = True End Sub

Sub savkop() Application.ScreenUpdating = False Dim a As String Dim b As String Dim c As String Dim bk As Workbook a = ThisWorkbook.Name b = "PBZ_" & Range("B2").Value Set bk = Workbooks.Add c = ActiveWorkbook.Name Windows(a).Activate Sheets("DV-Zeit").Select Sheets("DV-Zeit").Copy Before:=Workbooks(c).Sheets(1) Workbooks(c).Activate Application.DisplayAlerts = False Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3")).Select Sheets("Tabelle3").Activate ActiveWindow.SelectedSheets.Delete Application.DisplayAlerts = True Cells.Select Selection.Copy Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("A1").Select Application.CutCopyMode = False ActiveWorkbook.SaveAs Filename:="G:\User\PDL\PBZ\" & b & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False ActiveWindow.Close Application.ScreenUpdating = True End Sub

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread