werkblad export naar xlsx revisiebeheer

[Doohan]

Beste Helper,

Ik gebruik onderstaand code om een saveas actie te doen op mijn werkblad

Sub SumOctaaf()
    Dim FName As String
    Dim FPath As String
    Dim sh As Worksheet
    
    Application.DisplayAlerts = False
      For Each sh In Sheets
        If sh.Name <> ActiveSheet.Name Then sh.Delete
      Next sh
    
    FPath = "U:\xlsx\" & Range("A5").Text
    FName = Sheets("Optelling per Octaafband").Range("e2").Value & " - Optelling per Octaafband " & Format(Date, "DD-MM-YYYY")
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:=FPath & "\" & FMap & FName & ".xlsx", FileFormat:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
    Application.DisplayAlerts = True
    Application.Quit
End Sub

De code werkt goed maar, als ik de code voor de 2e keer uitvoer word het bestand die de 1ste x gemaakt werd overschreven. Wat ik eigenlijk graag zou willen is dat er automatisch een vorm van revisie achter komt.
Het liefst zou ik willen format date dus vervangen word door rev0 en als het bestand bestaat op de locatie dat deze vervangen word door rev1 of rev2 of rev3 een soort teller dus is dit mogelijk.

In afwachting op Uw wijs antwoord verblijf ik,
m.vr.gr.Martin

 

[cow18]

kan het moeilijk testen, maar dit zou moeten in de buurt komen

Sub SumOctaaf()
   Dim FName   As String
   Dim FPath   As String
   Dim sh      As Worksheet, RevNr

   Application.DisplayAlerts = False
   For Each sh In Sheets
      If sh.Name <> ActiveSheet.Name Then sh.Delete
   Next sh

   FPath = "U:\xlsx\" & Range("A5").Text         'pathname
   FName = Sheets("Optelling per Octaafband").Range("e2").Value & " - Optelling per Octaafband Rev"   '& Format(Date, "DD-MM-YYYY")'filename met achterin Rev

   [COLOR="#FF0000"]a = Split(Replace(CreateObject("wscript.shell").exec("cmd /c Dir " & FPath & "\" & FName & "*.xlsx" & "/b").stdout.readall, FPath, ""), vbCrLf)   'zoek alle bestaande dergelijke filenames
   RevNr = 0                                     'start bij revisienr 0
   For i = 0 To UBound(a)                        'alle filenamen aflopen
      s = Mid(Split(a(i), ".")(0), Len(FName) + 2)   'opzoeken versienr
      If IsNumeric(s) Then RevNr = Application.Max(RevNr, --s + 1)   'hoogste versienr zoeken
   Next[/COLOR]

   Application.DisplayAlerts = False
   ActiveWorkbook.SaveAs Filename:=FPath & "\" & FName & [COLOR="#FF0000"]RevNr &[/COLOR] ".xlsx", FileFormat:=51, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
   Application.DisplayAlerts = True
   Application.Quit
End Sub

 

[huijb]

@ Doohan Ik weet niet wat je allemaal aan het doen bent maar het is niet volgens de regels. Eerst inbreken in iemand zijn vraag en nu dubbel plaatsen. Verdiep je in de huisregels voor je een vraag plaatst.

 

[Doohan]

@Huijb
Je heb gelijk ik had al sorry gezegd

@cow18
Ik heb de code geprobeerd maar ik krijg de melding Fout 9 tijdens uitvoering, Het script valt buiten bereikop deze regel

   s = Mid(Split(a(i), ".")(0), Len(FName) + 2)   'opzoeken versienr

 

[HSV]

Probeer het zo maar eens.

   For i = 0 To UBound(a) [COLOR=#ff0000]- 1[/COLOR]

 

[Doohan]

werkblad export naar xlsx reveisiebeheer

Dank HSV,

De code loopt nu door, ik zie netjes rev0 verschijnen echter als ik de aktie nog een keer doe wordt rev0 gewoon overschreven er verschijnt geen rev1 achter de bestandsnaam.

Als bijlage de file met de code