Opslaan

[Jos1234]

Ik heb een en ander ivm automatische bestandsnaam gevonden in
http://www.helpmij.nl/forum/showthread.php?t=248022

Het antwoord op de vraag die daar onbeantwoord is gebleven interesseert mij ook:
Kun je de optie "overschrijven van het bestand" ook voorzien?
Jos

 

[LucB]

Hallo Jos,

Kun je hier wat mee.


Sub Opslaan_Overschrijven()
'Maakt een nieuw bestand met de tekst van A1 als Bestandsnaam
'Als de tekst in A1 niet verandert wordt het bestand overschreven.
Dim sText As String
ActiveSheet.Copy
sText = ActiveSheet.Range("A1").Value & ".xls"
Application.DisplayAlerts = False 'Je krijgt geen melding dat het bestand al bestaat.
ActiveWorkbook.SaveAs sText
Application.DisplayAlerts = True
End Sub

 

[Jos1234]

Foutmelding

Luc
Ik krijg een foutmelding:
fout 1004 tijdens uitvoering:
U kunt dit bestand niet opslaan onder dezelfde naam als dat van een andere geopende werkmap of invoegtoepassing. Kies een anderen naam of sluit de andere werkmap of invoegtoepassing voordat u opslaat.
Met dan de mogelijkheid om te kiezen tussen Beëindigen, Foutopsporing of Help

Hieronder de code die ik aan deze knop heb gekoppeld:

Private Sub OpslaanAlsknop_Click()
Dim new_filepath As String
Dim new_filename As String

new_filepath = ThisWorkbook.Path
new_filename = new_filepath & Application.PathSeparator & Sheets(1).Range("H2") & ".xls"
Do
If Chk(new_filename) Then
Dim sText As String
ActiveSheet.Copy
sText = ActiveSheet.Range("h2").Value & ".xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sText
Application.DisplayAlerts = True
End If
Loop While Chk(new_filename)
ThisWorkbook.SaveAs new_filename
End Sub

Jos

 

[jpvs]

Misschien kun je dit gebruiken :

Sub SaveTheFile()
Dim sPath As String
Dim sRoot As String

On Error GoTo Oops
sRoot = Application.DefaultFilePath
If Right(sRoot, 1) <> "\" Then sRoot = sRoot & "\"

sPath = sRoot & "PL " & ActiveSheet.Range("b1").Value & ".xls"

If fExists(sPath) Then
If MsgBox("Wenst u het bestand te overschrijven?", vbYesNo) = vbYes Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sPath
Else
If MsgBox("Wenst u het bestand onder een andere naam op te slaan?", vbYesNo) = vbYes Then
sPath = sRoot & InputBox("Geef de naam") & ".xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sPath
End If
End If
Else
ActiveWorkbook.SaveAs sPath
End If
Oops:
If Application.DisplayAlerts = False Then Application.DisplayAlerts = True
End Sub

Pierre

 

[LucB]

Jos,

Probeer de code die ik in eerste instantie gaf.
Die doet dacht ik wat je vroeg.( Als de tekst in A1 niet verandert wordt er overschreven)

Twee codes combineren pakt in dit geval niet goed uit.

 

[Jos1234]

Misschien kun je dit gebruiken :

Sub SaveTheFile()
Dim sPath As String
Dim sRoot As String

On Error GoTo Oops
sRoot = Application.DefaultFilePath
If Right(sRoot, 1) <> "\" Then sRoot = sRoot & "\"

sPath = sRoot & "PL " & ActiveSheet.Range("b1").Value & ".xls"

If fExists(sPath) Then
If MsgBox("Wenst u het bestand te overschrijven?", vbYesNo) = vbYes Then
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sPath
Else
If MsgBox("Wenst u het bestand onder een andere naam op te slaan?", vbYesNo) = vbYes Then
sPath = sRoot & InputBox("Geef de naam") & ".xls"
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs sPath
End If
End If
Else
ActiveWorkbook.SaveAs sPath
End If
Oops:
If Application.DisplayAlerts = False Then Application.DisplayAlerts = True
End Sub

Pierre

Ik krijg een foutmelding bij de functie fExists.

Jos

 

[jpvs]

LucB,

Telkens als ik de macro start komt er een melding "400" wat dit ook wil zeggen en wordt er een nieuwe map aangemaakt ?

Jos,

Zet dit nog achter de macro dan zal het wel werken.

Public Function fExists(ByVal sFile As String) As Boolean
If Len(sFile) = 0 Then Exit Function: fExists = False

If Dir(sFile, vbDirectory) <> "" Then
fExists = True
Else
fExists = False
End If

End Function

In cel B1 kun je bv een naam zetten (Testing) dan wordt de map PL Testing.xls genoemd.

Pierre

 

[Jos1234]

Bedankt

Pierre (en ook Luc natuurlijk)
Bedankt.

Het werkt zoals ik het had gewild.

Jos

 

[LucB]

Voor Pierre,

Je krijgt die merkwaardige "Error 400"
Een jaar geleden heb ik die ook eens gehad met een andere Code.
De fout is vanzelf verdwenen.

Maar in jouw geval zou je eens kunnen proberen tekst in A1 in te voeren en
kijken of het dan ook gebeurt.
Als A1 nl leeg blijft moet ie niks opslaan en dat gaat niet.

Je zou ook nog kunnen Googlen op VBA Error 400.

 

[jpvs]

Luc,

Getest en Error blijft weg.

Pierre