opslaan en klasseren

[vio]

Hoi,
Is het mogelijk om een tabblad op te slaan voorafgaand met de datum van vandaag gevolgd met de naam van het tabblad. De code zou dan dit tabblad moeten klasseren in een map in gedeelde bestanden. Onderstaande code heb ik al maar als ik het naar een map in gedeelde bestanden plaats moet ik nog eens vijf mappen open voordat ik er ben.
Is het mogelijk met een VBA code?

Sub Opslaan()
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
Bestandsnaam = Application.GetSaveAsFilename( _
fileFilter:="Excelbestanden (*.xls), *.xls")
If Bestandsnaam <> False Then
ActiveWorkbook.SaveAs Bestandsnaam
ActiveWorkbook.Close savechanges = False
End If

De code van http://www.rondebruin.nl/mail/folder1/mail2.htm heb ik ook al geprobeert maar om de een of andere redenen wordt TempFilePath in C:\ geplaats ipv in G:\ enkele keren ging dit goed en nadien plaatst de code het bestand weer op in C:\
Weet iemand raad?

Bij voorbaat dank,
Vio

 

[Warme bakkertje]

Wijzig nog enkel de gewenste directory en het gewenste bereik

Sub Blad_opslaan()
Dim sName As String, i As Integer
With Application
    .ScreenUpdating = False
    .DisplayAlerts = False
End With
ChDir "D:\Mijn documenten\Helpmij\" 'wijzig naar gewenste directory
sName = ActiveSheet.Name
[A1:I50].Copy ' wijzig in het juiste kopieërbereik
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
For Each sh In Worksheets
    If sh.Index > 1 Then
    sh.Delete
    End If
Next
With ActiveWorkbook
    .SaveAs Filename:=Format(Date, "dd-mm-yyyy") & " " & sName & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
    .Saved = True
    .Close
End With
With Application
    .ScreenUpdating = True
    .DisplayAlerts = True
End With
MsgBox "File is opgeslagen"
End Sub

Mvg

Rudi

 

[vio]

Ontzaggelijk

Fantastisch Rudi,:thumb::thumb::thumb::thumb:
Ik heb een stukje uit een andere code er tussen gezet(zie onder) en het werkt perfect en snel. Hopelijk zal dat ook gelden als ik het opsla in gedeelde bestanden in een andere computer maar dat weet ik pas vrijdag.

Sub Blad_opslaan()

Dim sName As String, i As Integer
With Application
.ScreenUpdating = False
.DisplayAlerts = False
End With
ChDir "C:\Users\home\Documents\vio\vi"
sName = ActiveSheet.Name
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
For Each Sh In Worksheets
If Sh.Index > 1 Then
Sh.Delete
End If
Next
With ActiveWorkbook
.SaveAs Filename:=Format(Date, "dd-mm-yyyy") & " " & sName & ".xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
.Saved = True
.Close
End With
With Application
.ScreenUpdating = True
.DisplayAlerts = True
End With
MsgBox "File is opgeslagen"
End Sub

Hartelijke groeten,
Vio