Ahoj. Vyber si co potřebuješ z této funkce.
- Vytváří nový adresář podle datumu nebo nakopíruje do existujícího adresáře
- Vytvoří (zkopíruje) více listů najednou
- Uloží pod datumem a jménem
- Pokud máš nějaký kommrimační program, pak se Ti vytvoří archív. Archív vytvářím proto, že konti tabulky jsou objemné ale dají se velmi dobře komprimovat. Po tomto volám funkci na sestavení a odeslání emailu. 7z je free a vypadá to moc hezky, když jej voláš z VBA. R.
Function uloz_sestavu_do_souboru()
Dim i As Long
Dim OutSesit As Workbook
Dim SrcSesit As Workbook
Dim fs As Object
Dim f As Object
Dim adresar As String
Dim NewFileName As String
Dim exc As String
On Error GoTo LabelErr
With Worksheets(cWorkData)
.Activate
Set fs = CreateObject("Scripting.FileSystemObject")
adresar = cPathFile & Format(Now(), "yyyy mm dd")
If Not fs.FolderExists(adresar) Then
fs.CreateFolder (adresar)
End If
'Set f = fs.GetFile(cPathFile)
End With
GoTo LabelOK
LabelErr:
MsgBox "Chyba : " & Err.Number & " - " & Err.Description
Exit Function
LabelOK:
On Error GoTo 0
Set SrcSesit = ActiveWorkbook
Worksheets(Array("DATA", "PIVOT", "PIVOT 1", "PIVOT 2")).Copy
Set OutSesit = ActiveWorkbook
SrcSesit.Activate
NewFileName = adresar & "\" & Format(Now(), "yyyy mm dd") & " - FG.xls"
' Call kopiruj_vba_kody
Application.DisplayAlerts = False
OutSesit.SaveAs Filename:=NewFileName
OutSesit.Close SaveChanges:=True
Application.DisplayAlerts = True
exc = cPath7z & "7zG.exe a """
exc = exc & adresar & "\" & Format(Now(), "yyyy mm dd") & " - FG.zip"" """
exc = exc & adresar & "\" & Format(Now(), "yyyy mm dd") & " - FG.xls"""
' Debug.Print exc
Call ChDir(cPath7z)
Call Shell(exc, 1)
' Nastav zpět adresář pro otevírání souborů.
Call ChDir("c:\GTable\")
End Function
citovat
- Vytváří nový adresář podle datumu nebo nakopíruje do existujícího adresáře
- Vytvoří (zkopíruje) více listů najednou
- Uloží pod datumem a jménem
- Pokud máš nějaký kommrimační program, pak se Ti vytvoří archív. Archív vytvářím proto, že konti tabulky jsou objemné ale dají se velmi dobře komprimovat. Po tomto volám funkci na sestavení a odeslání emailu. 7z je free a vypadá to moc hezky, když jej voláš z VBA. R.
Function uloz_sestavu_do_souboru()
Dim i As Long
Dim OutSesit As Workbook
Dim SrcSesit As Workbook
Dim fs As Object
Dim f As Object
Dim adresar As String
Dim NewFileName As String
Dim exc As String
On Error GoTo LabelErr
With Worksheets(cWorkData)
.Activate
Set fs = CreateObject("Scripting.FileSystemObject")
adresar = cPathFile & Format(Now(), "yyyy mm dd")
If Not fs.FolderExists(adresar) Then
fs.CreateFolder (adresar)
End If
'Set f = fs.GetFile(cPathFile)
End With
GoTo LabelOK
LabelErr:
MsgBox "Chyba : " & Err.Number & " - " & Err.Description
Exit Function
LabelOK:
On Error GoTo 0
Set SrcSesit = ActiveWorkbook
Worksheets(Array("DATA", "PIVOT", "PIVOT 1", "PIVOT 2")).Copy
Set OutSesit = ActiveWorkbook
SrcSesit.Activate
NewFileName = adresar & "\" & Format(Now(), "yyyy mm dd") & " - FG.xls"
' Call kopiruj_vba_kody
Application.DisplayAlerts = False
OutSesit.SaveAs Filename:=NewFileName
OutSesit.Close SaveChanges:=True
Application.DisplayAlerts = True
exc = cPath7z & "7zG.exe a """
exc = exc & adresar & "\" & Format(Now(), "yyyy mm dd") & " - FG.zip"" """
exc = exc & adresar & "\" & Format(Now(), "yyyy mm dd") & " - FG.xls"""
' Debug.Print exc
Call ChDir(cPath7z)
Call Shell(exc, 1)
' Nastav zpět adresář pro otevírání souborů.
Call ChDir("c:\GTable\")
End Function
citovat
RSS nejnovější články