Oplsaan specifieke folder

[Tweety1]

Onderstaande macro gebruik om een bestand op te slaan. De macro werkt in principe goed alleen zou ik het volgende willen aanpassen.

1. Indien het bestand al bestaat vraagt excel of ik het bestand wil vervangen indien ik nee druk dan zou ik graag folder willen zien waar het bestand bestaande bestand is opgeslagen.
2. Al ik aangeef annuleren dan zou ik graag direct eruit willen en niet eerst het scherm waar ik een naam kan geven.

Function SavingWorkbook()
Dim strDate As String
Dim strFolder As String
Dim StrName As String
Dim strFile As String
Dim Arg1 As String
Dim Arg3 As String
Dim FN As String
Dim WasSaved As Boolean
Dim ret As Boolean
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
        
strDate = Format(Now, "dd-mm-yyyy")
strFolder = ThisWorkbook.Sheets("Blad3").Range("G1").Value
StrName = ThisWorkbook.Sheets("Blad3").Range("B2").Value

FN = strFolder & "\" & "test " & StrName & " (" & strDate & ")" & ".xlsm"
WasSaved = False

On Error Resume Next
ActiveWorkbook.SaveAs FN, _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

If Err.Number = 0 Then

WasSaved = True

Else



Err.Clear


ret = Application.Dialogs(xlDialogSaveAs).Show(FN, 52)
    
If ret = True Then

strFile = ActiveWorkbook.FullName
    If InStr(strFile, "\") = 0 Then
        MsgBox "This workbook hasn't been saved yet", vbExclamation
        Exit Function
    End If
    ActiveWorkbook.Close savechanges:=True ' or False, if you prefer
    Workbooks.Open Filename:=strFile

'saved with some name

WasSaved = True

End If
End If
On Error GoTo 0

If WasSaved = True Then

'ActiveWorkbook.Close savechanges:=False
strFile = ActiveWorkbook.FullName
    If InStr(strFile, "\") = 0 Then
        MsgBox "This workbook hasn't been saved yet", vbExclamation
        ' Doorgaan = False
        Exit Function
    End If
    ActiveWorkbook.Close savechanges:=True ' or False, if you prefer
    Workbooks.Open Filename:=strFile
    ' Doorgaan = True

Else
MsgBox "This workbook hasn't been saved yet", vbExclamation ' "not saved!"

SavingWorkbook = "stop"

End If

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
End Function

Gr. Kasper

 

[edmoor]

Wat je wilt is geen enkel probleem maar dan is er wel eerst antwoord nodig op de volgende vragen:

Waarom een Function en geen Sub?
Ook zie ik dat de eerder gebruikte parameter met de naam "Doorgaan" verwijderd is. Om welke reden is dat gedaan?
Tevens worden er onnodig de variabelen Arg1 en Arg3 gedeclareerd. Is daar een reden voor?

De eerste vraag is het belangrijkst. Als je daar antwoord op geeft wil ik het wel voor je maken.

 

[Tweety1]

Ik heb de functie gebruikt om vanuit een ander macro de functie (Macro) aan te sturen.
De macro mag namelijk niet verder gaan als de folder niet bestaat en als het bestand niet wordt opgeslagen.
Arg1 en Arg3 heb ik gebruikt om de naam te laten zien en het bestand op te laten slaan als xlsm bestand (er word namelijk een tabblad uit een ander bestand gekopieerd waar een macro in staat).


Begin

Sub Voorbeeld1()
  Dim Doorgaan As String
  
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    
    On Error Resume Next
    ActiveSheet.Select
    With ActiveSheet
    
    If Err.Number > 0 Then
        MsgBox "There is no workbook open"
        Err.Clear
        On Error GoTo 0
    Else
    
  
   If Range("A1").Value = "Export" Then
  
    Doorgaan = Folder()
    If Doorgaan = "stop" Then
    Exit Sub
    End If

    Doorgaan = SavingWorkbook()
    If Doorgaan = "stop" Then
    Exit Sub
    End If

  Macro1
  Macro2
  
  Else
  
  MsgBox "Sorry, Incorrect Formatting", vbExclamation
  
  End If
  
ActiveWorkbook.Save

CommonExit:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End If
End With
End Sub

Folder

Function Folder()
Dim TestStr As String
Dim strFolder As String
Dim strFolder1 As String

With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
        
    strFolder = ThisWorkbook.Sheets("Blad3").Range("G1").Value
    strFolder1 = ThisWorkbook.Sheets("Blad3").Range("G1").Value

   If Right(strFolder, 1) <> "\" Then
        strFolder = strFolder & "\"
   
   End If
   
    TestStr = ""
    On Error Resume Next
    TestStr = Dir(strFolder)
    On Error GoTo 0
    If TestStr = "" Then
        MsgBox "Folder doesn't exist" & vbCrLf & vbCrLf & strFolder1
     Folder = "stop"
    Exit Function
    
    Else
    End If

End Function

 

[Tweety1]

Wat eventueel ook mag is automatisch een getal (oplopend) erachter zetten

 

[Tweety1]

@edmoor

Kun je mij nog vertellen of het nog gaat lukken.

 

[edmoor]

Om 1 of andere reden heb ik deze na mijn eerste reactie helemaal gemist. Ik zal er vanavond eens naar kijken.

 

[edmoor]

Wil je nog even uitleggen wat precies je vraag is in #1? De beide Subs in #3 kun je eenvoudig door 1 Sub vervangen door andere controle methodes te gebruiken:

Sub Voorbeeld1()
    If Application.Workbooks.Count = 0 Then
        MsgBox "There is no workbook open"
        Exit Sub
    End If

    If Range("A1").Value = "Export" Then
        If Dir(ThisWorkbook.Sheets("Blad3").Range("G1").Value, vbDirectory) = VbNullString Then
            MsgBox "Non existing folder"
            Exit Sub
        End If
    Else
        MsgBox "Sorry, Incorrect Formatting", vbExclamation
        Exit Sub  
    End If
  
    Macro1
    Macro2

    ActiveWorkbook.Save
End Sub

 

[Tweety1]

De macro werkt op zich goed als je het bij de eerste x uitvoert. Zodra ik voor de 2e keer de macro draai dan geeft hij aan dat het bestand al bestaat en of ik de dat wil vervangen. Als Ja aangeeft gaat alles goed. Zeg ik Nee dan kan ik zelf de naam veranderen. Nu zou ik graag uit willen komen in de map waar ook het bestaande bestand staat.