Opslaan op waarde, als map niet bestaan andere map opslaan

[edmoor]

Ok. Dit dus:

Sub save1()
    pad1 = "\\SERVER1\Data\automatisering\Offerte nieuw\Opslag\Test opslaan op waarde\" & [A1] & "\"
    pad2 = "\\SERVER1\Data\automatisering\Offerte nieuw\Opslag\Test opslaan op waarde\Nog toe te wijzen\"
    bst = [C10] & ", " & [A1] & ", " & [C12] & ".xls"
    
    Application.DisplayAlerts = False
    With Workbooks.Add
        With .Sheets(1)
            Columns("A:A").ColumnWidth = 11.71
            ThisWorkbook.Sheets("Leeg").Range("1:500").Copy .[A1]
            ThisWorkbook.Sheets("Leeg").Range("A:S").Copy .[A1]
            ActiveWindow.DisplayGridlines = False
            If Dir(pad1, vbDirectory) = "" Then
                bst = pad2 & bst
            Else
                bst = pad1 & bst
            End If
            .Parent.SaveAs bst, FileFormat:=xlExcel8
        End With
    End With
    Application.DisplayAlerts = True
End Sub

 

[HWV]

Edmoor,

Geweldig het doet zeker wat het moet doen.

Mijn exccuus dat het niet in eerste instantie duidelijk was.
Leer mij weer als ik de volgende keer hulp nodig heb dat ik het beter moet formuleren, en gelijk met voorbeeld bestand moet komen.

Ik ga kijken of ik het nu ook zo in het orginele bestand werkzaam gaat krijgen, maar voor nu alvast erg bedankt

Groet Henk

 

[edmoor]

Graag gedaan
Dan nu nog de vraag waarom je het document als .xls opslaat in plaats van .xlsx

 

[HWV]

Tja als je het zo vraag dan weet ik het niet, dus dan zal het wel beter zijn om dit in de nieuwste versie op te slaan dus .xlsx
Zal deze verandering testen onder de gebruikers, zal wel geen problmen opleveren, ik denk eerder een melding minder


Henk

 

[edmoor]

Een .xls document zal op een gegeven moment problemen kunnen geven omdat deze altijd in compatibility mode in Excel draait. Niet alle functionaliteit vanaf Excel 2007 zal dat werken en zou je tegenaan kunnen lopen.

 

[HWV]

Loop toch nog even vast

Beste Edmoor,

Ik heb het in gebruik genomen met een paar aanpassingen voor het zoeken in de directory of de map bestaat en het werkt perfect op het orginele bestand.
Nu we er mee werken zou ik eigenlijk willen als de directory niet bestaat dat die dan wordt aangemaakt met de opgegeven naam in pad1 en dat daar dan het bestand in wordt gezet.

Ik heb iets wat ik denk er in te gebruiken, maar dan geef hij aan onvoldoende geheugen

Sub MaakDir()
    Dim sDir As String
    sDir = _
    "\\SERVER1\Data\automatisering\Offerte nieuw\Opslag\Test opslaan op waarde\" & [A1] & " - " & [C1] & " - " & [D1] & ""
    MkDir sDir
     
End Sub

Zo iets zou ingepast moeten worden in onderstaande, en dan denk ik in plaats van Pad2

Misschien dat er een kopie gemaakt kan worden van een bestaande map, want in deze map zitten namelijk nog 6 submappen.
We kunnen deze opnieuw aanmaken met VBA maar misschien ook mogelijk om een bestaande map te kopiëren.
Ik heb eerlijkgezegd geen idee hoe dit moet

Sub save1()
    pad1 = "\\SERVER1\Data\automatisering\Offerte nieuw\Opslag\Test opslaan op waarde\" & [A1] & " - " & [D1] & " - " & [E1] & "\"
    pad2 = "\\SERVER1\Data\automatisering\Offerte nieuw\Opslag\Test opslaan op waarde\Nog toe te wijzen\"
    bst = [C10] & ", " & [A1] & ", " & [C12] & ".xls"
    
    Application.DisplayAlerts = False
    With Workbooks.Add
        With .Sheets(1)
            Columns("A:A").ColumnWidth = 11.71
            ThisWorkbook.Sheets("Leeg").Range("1:500").Copy .[A1]
            ThisWorkbook.Sheets("Leeg").Range("A:S").Copy .[A1]
            ActiveWindow.DisplayGridlines = False
  
            If Dir(pad1, vbDirectory) = "" Then
                bst = pad2 & bst
                MsgBox ("Map bestaat nog niet, wordt geplaatst in de map -Nog toe te wijzen-")
            Else
                bst = pad1 & bst
            End If
            .Parent.SaveAs bst, FileFormat:=xlExcel8
        End With
    End With
    Application.DisplayAlerts = True
End Sub

Al weer bedankt voor de hulp.

Bekijk bijlage Offerte programma.xlsm
Henk

ps.
Geprobeerd deze over te zetten naar .xlsx maar daar loop ik in vast had ook al FileFormat:=xlExcel8 aangepast naar FileFormat:=xlExcel52