Tabellenblatt automatisch in Ordner abspeichern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Namenloser,
Probier mal (unter der Annahme, dass die Sub-Verzeichnisse unter dem Verzeichnis liegen, in dem die Arbeitsmappe abgespeichert ist) :

Option Explicit
' Diesen Code in ein Standardmodul
Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal Pfad As String) As Long
'   GetMoreSpeed
Sub GetMoreSpeed(Optional ByVal Modus As Boolean = True)
Static intCalculation As Integer
If Modus = True Then intCalculation = Application.Calculation
With Application
.ScreenUpdating = Not Modus
.EnableEvents = Not Modus
.Calculation = IIf(Modus = True, xlManual, intCalculation)
.Cursor = IIf(Modus = True, 2, -4143)
End With
End Sub

und dann noch so:

Option Explicit
' Diesen Code in das zu kopierende Tabellenblatt mit dem
' ActiveX Steuerelement CommandButton
Private Sub CommandButton1_Click()
Dim sWBName As String
Dim SubPathName As String
Dim NewWBName As String
GetMoreSpeed True
SubPathName = "\" & Format(Cells(2, 1), "MMMM YYYY") & "\"
NewWBName = Me.Name & "_" & Cells(2, 1).Text & ".xlsx"
UsedRange.Copy
MakeSureDirectoryPathExists (ThisWorkbook.Path & SubPathName)
Workbooks.Add
With ActiveWorkbook
With .Worksheets(1)
.Name = Me.Name
.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths
End With
Application.DisplayAlerts = False
Do While .Worksheets.Count > 1
.Worksheets(2).Delete
Loop
Application.DisplayAlerts = True
sWBName = ThisWorkbook.Path & SubPathName & NewWBName
.SaveAs sWBName
.Close
End With
Application.CutCopyMode = False
MsgBox "Daten gespeichert unter" & vbCrLf & _
sWBName, vbOKOnly + vbInformation
GetMoreSpeed False
End Sub

Gruess Hansueli

Option Explicit ' Diesen Code in das zu kopierende Tabellenblatt mit dem ' ActiveX Steuerelement CommandButton Private Sub CommandButton1_Click() Dim sWBName As String Dim SubPathName As String Dim NewWBName As String Dim sh As Shape, lX As Long GetMoreSpeed True SubPathName = "\" & Format(Cells(2, 1), "MMMM YYYY") & "\" NewWBName = Me.Name & "_" & Cells(2, 1).Text & ".xlsx" UsedRange.Copy MakeSureDirectoryPathExists (ThisWorkbook.Path & SubPathName) Workbooks.Add With ActiveWorkbook With .Worksheets(1) .Name = Me.Name .Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats .Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths ' Copy all Charts to the new Worksheet. Omit all other shapes On Error Resume Next For Each sh In Me.Shapes If Left(sh.Name, 6) = "Chart " Then sh.Copy .PasteSpecial Format:="Bild (GIF)", Link:=False, DisplayAsIcon:=False Do While Err.Number 0 Application.Wait (Now + TimeValue("0:00:01")) Err.Clear .PasteSpecial Format:="Bild (GIF)", Link:=False, DisplayAsIcon:=False Loop lX = lX + 1 .Shapes(lX).Left = sh.Left .Shapes(lX).Top = sh.Top End If Next sh On Error GoTo 0 Application.CutCopyMode = False End With Application.DisplayAlerts = False Do While .Worksheets.Count > 1 .Worksheets(2).Delete Loop Application.DisplayAlerts = True sWBName = ThisWorkbook.Path & SubPathName & NewWBName .SaveAs sWBName .Close End With Application.CutCopyMode = False MsgBox "Daten gespeichert unter" & vbCrLf & _ sWBName, vbOKOnly + vbInformation GetMoreSpeed False End Sub

Beliebteste Forumthreads (12 Monate)

Tabellenblatt automatisch in Ordner abspeichern

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Tabellenblatt automatisch in Ordner abspeichern

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

304 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread