opslaan in map met variabele naam

[DesignerQZ]

Hallo,

Ik heb een bestand dat via een macro opgeslagen dient te worden met de juiste naam in een bepaalde map. Is het mogelijk om te laten zoeken naar een map waarvan de naam altijd begint met een bepaalde code, maar dat die map misschien wel meer aanvullende gegevens in de naam heeft? Bijvoorbeeld: De naam van de map begint altijd met "25-001", maar soms ook "25-001 Janssen Amsterdam". In deze map staat dan weer een sub-map met de naam "Calculatie en offerte", en dat is dan weer de map waar het in moet.

Ik gebruik deze code, maar die werkt alleen als de map ook daadwerkelijk "25-051" heet:

Sub ExcelOpslaan()


With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = Range("c1")

ActiveWorkbook.SaveAs Range("a37") & "\" & Range("c1") & ".xlsm"

End With

End Sub
C1= "25-051"
A37= "M:\1. OFFERTES\Calc 2025\25-051\Calculatie en Offerte" (Dit is een formule die deze tekst genereert uit andere cellen)

De naam van de map wordt nogal eens aangevuld met extra informatie, maar zal altijd blijven beginnen met "25-051".
Het is natuurlijk het makkelijkste wanneer ik tegen iedereen kan zeggen: "Je mag die naam niet meer wijzigen", maar dat roept zoveel weerstand op dat ik benieuwd ben of hier een oplossing voor is waarbij dit dynamisch kan

 

[AHulpje]

Gebruik de uitkomst van deze functie als pad voor het opslaan van het bestand Range("C1") & ".xlsm" waarbij je het deel

"M:\1. OFFERTES\Calc 2025\"

zelf even moet samenstellen uit de onderdelen.

Function GetFolder() As String
    Dim orgpath As String
    Dim newpath As String
    Dim subpath As String
    Dim fName As Variant
    
    orgpath = Range("A37")
    fName = Dir("M:\1. OFFERTES\Calc 2025\", vbDirectory)

    Do While fName <> ""
        If Left(fName, 6) = "25-051" Then
            subpath = fName
        End If
        fName = Dir()
    Loop
    orgpath = Replace(orgpath, "25-051", subpath)
    GetFolder = newpath
End Function