map aanmaken en opslaan als middels macro

[baanm]

Hoi Allemaal,

Het projectbestand PROJECT 000 begint als blanco template (read only) en na invullen (o.a. "projectnr" en "projectname") kan deze ergens op ons netwerk opgeslagen worden.
Middels tekst-samenvoegen (deels vanuit ander bestand) wordt in "filepath" de plaats op ons netwerk aangegeven. Echter bestaat de kans, dat die projectfolder (nog) niet bestaat.

Wie kan mij helpen met een stuk macro, waarbij het bestand wordt opgeslagen volgens het file path volgens cel "filepath"?
Wellicht te ingewikkeld om alles in een macro te maken.
Hoe maak ik dan eerst een map aan?

Groet,

Baan

 

[Niels28]

Hierbij een voorbeeldje van hoe je dat zou kunnen doen.

    Sub opslaan()

    StPath = "F:\DATA\BLABLA"
    StFullPath = StPath & "\" & Sheets(1).Range("A1").Value
    
        With CreateObject("Scripting.FileSystemObject")
            If Not .FolderExists(StFullPath & "\") Then .CreateFolder StFullPath & "\"
            StFullName = StFullPath & "\test " & Sheets(1).Range("A1").Value & ".xlsm"
        End With
        
    With CreateObject("Scripting.FileSystemObject")
    If Not .FileExists(StFullName) Then
        ActiveWorkbook.SaveAs (StFullName)
    End If
        
    End Sub

Niels

 

[baanm]

Dank je Niels.

Ik denk dat ik begrijp wat de macro doet. Nu heb er dit van gemaakt:

Sub save()

    StPath = projectspath 
    StFullPath = StPath & "\" & foldername .Value
            With CreateObject("Scripting.FileSystemObject")
            If Not .FolderExists(StFullPath & "\") Then .CreateFolder StFullPath & "\"
            StFullName = StFullPath & "\filename .Value & ".xlsm"
        End With
        
    With CreateObject("Scripting.FileSystemObject")
    If Not .FileExists(StFullName) Then
        ActiveWorkbook.SaveAs (StFullName)
    End If
        
    End Sub

Ik heb een aantal celnamen gebruikt in plaats van bijv. Sheets(1).Range("A1").Value
Maar dat geeft een aantal compilatiefoutjes.
Waarschijnlijk een aantal spaties, streepjes en komma's teveel of te weing gebruikt.
Kan iemand dat vlottrekken?

Groet Baan

 

[Niels28]

celnamen geeft je aan als

range("foldername").value

en

range("filename").value

Niels

 

[baanm]

het is aan het lukken...

Dit heb ik er van gemaakt (met behulp van Niels) en het werkt:

  Sub save()

    StPath = Range("projectspath").Value
    StFullPath = StPath & "\" & Range("foldername").Value
            With CreateObject("Scripting.FileSystemObject")
            If Not .FolderExists(StFullPath & "\") Then .CreateFolder StFullPath & "\"
            StFullName = StFullPath & "\" & Range("filename").Value & ".xlsm"
        End With
        
    With CreateObject("Scripting.FileSystemObject")
    If Not .FileExists(StFullName) Then
        ActiveWorkbook.SaveAs (StFullName)
    End If
    End With
        
    End Sub

Ben ik al erg blij mee.

Wanneer deze knop nogmaals gebruikt wordt (folder en bestand bestaan dus al op het netwerk) lijkt er niets te gebeuren. Ook een verandering wordt niet opgeslagen. Ik krijg ook geen waarschuwing dat de file al bestaat.

Is daar nog wat te verbeteren? Is deze macro te verbouwen tot een opslaan(als) functie, met waarschuwing: "deze file bestaat al!" Al of niet met een vervolgactie: "Overschrijven? yes/no?"


Ben benieuwd.

Groet,

Baan

 

[Niels28]

Het was ook een voorbeeldje, zo wordt er niet gecontoleerd of het bestand al bestaat en krijg je de vraag of je het bestand wil overschrijven.

als je de (') voor application.display alerts weg haalt krijg je de vraag ook niet meer.

 Sub save()

    StPath = Range("projectspath").Value
    StFullPath = StPath & "\" & Range("foldername").Value
            With CreateObject("Scripting.FileSystemObject")
            If Not .FolderExists(StFullPath & "\") Then .CreateFolder StFullPath & "\"
            StFullName = StFullPath & "\" & Range("filename").Value & ".xlsm"
        End With
        'application.displayalerts = false
        ActiveWorkbook.SaveAs (StFullName)
        'application.displayalerts = true
        
    End Sub

Niels

 

[baanm]

het werkt!

Dank je Niels. Werkt perfect.
Werkt verslavend:

Ik zou ook graag (bij de eerste keer opslaan, als de map nog niet bestaat) in een ander bestand "list" op blad "listblad" aansluitend op de bestaande lijst, in kolom F en H de inhoud van respectievelijk cel "projectnr" en "projectname" uit dit net opgeslagen bestand geplaatst zien.

Heeft iemand een idee hoe dit aan te pakken?

Groet,

Baan

 

[Niels28]

Ja het kan verslavend werken, dacht je dat we voor onze lol hier antwoorden geven...

Even uit de losse pols, niet getest.
ga er vanuit dat het bestand nog niet openstaat en daarna weer gesloten wordt.
De bestandsnaam en pad moet je zelf even veranderen.

 Sub save()

    StPath = Range("projectspath").Value
    StFullPath = StPath & "\" & Range("foldername").Value
            With CreateObject("Scripting.FileSystemObject")
                If Not .FolderExists(StFullPath & "\") Then .CreateFolder StFullPath & "\"
                StFullName = StFullPath & "\" & Range("filename").Value & ".xlsm"
                
                With Workbooks.Open("c:\map\bestandsnaam.xlsx")
                    .Sheets("listblad").Cells(Rows.Count, 6).End(xlUp).Row.Offset(1, 0).Value = Range("projectnr").Value
                    .Sheets("listblad").Cells(Rows.Count, 8).End(xlUp).Row.Offset(1, 0).Value = Range("projectname").Value
                    .Close savechanges:=True
                End With
            
            End With
        'application.displayalerts = false
        ActiveWorkbook.SaveAs (StFullName)
        'application.displayalerts = true
        
    End Sub

Niels

 

[baanm]

Hartelijke dank. Erg leerzaam.

Na enig pasmaken, loopt de macro tot en met het openen van de file. Het vinden van de sheet/cel lijkt nog een probleem. Ik krijg de volgende foutmelding bij deze rode regel: fout 424: object vereist.

 With Workbooks.Open(StProjectsupervision)
                    [COLOR="#FF0000"]
.Sheets("list").Cells(Rows.Count, 6).End(xlUp).Row.Offset(1, 0).Value = StNummer[/COLOR]                    
.Sheets("list of issues and projects").Cells(Rows.Count, 8).End(xlUp).Row.Offset(1, 0).Value = Range("projectname").Value
                    .Close savechanges:=True
                End With

Ik had vooraf het laatste stuk van de regel al gewijzigd naar STnummer (en ook gedefinieerd), in plaats van Range("projectnr").Value, omdat daar de foutmelding kwam over Methode Range van Object_global mislukt.
Nu komt in ieder geval bij foutopsporing de waarde te voorschijn. (de volgende regel staat er nog bij ter vergelijk.

Ik heb de naam van de sheet al verkort.
Wat te doen met de gemiste object?

Groet,

Baan

 

[Niels28]

Mijn fout, de .row moet er niet tussen staan.
geld ook voor de regel die er onder staat.

.Sheets("list").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Value = Range("projectname").Value

Niels

 

[baanm]

Wordt steeds beter. Maar..

Bij herhaald de macro starten, plaatst hij toch weer het projectnummer en naam in sheet "list" van het andere bestand, terwijl dat alleen moet, wanneer er ook een folder met dat projectnummer+naam aangemaakt wordt.
(het proces vraagt netjes of de bestaande file overschreven moet worden)

De code bekijkend zie ik niet waar het fout gaat.:

 Sub save()

    StProjectsupervision = Range("projectsupervisionpath").Value
    StPath = Range("projectspath").Value
    StFullPath = StPath & "\" & Range("foldername").Value
    StNummer = Range("projectnr").Value
    StName = Range("projectname").Value
    
            With CreateObject("Scripting.FileSystemObject")
                If Not .FolderExists(StFullPath & "\") Then .CreateFolder StFullPath & "\"
                StFullName = StFullPath & "\" & Range("filename").Value & ".xlsm"
                
                With Workbooks.Open(StProjectsupervision)
                    .Sheets("list of issues and projects").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Value = StNummer
                    .Sheets("list of issues and projects").Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).Value = StName
                    .Close savechanges:=True
                End With
            
            End With
        'application.displayalerts = false
        ActiveWorkbook.SaveAs (StFullName)
        'application.displayalerts = true
        
    End Sub

Waar zit de laatste (?)bug?

Groet,

Baan

 

[Niels28]

Zo dan?

 Sub save()

    StProjectsupervision = Range("projectsupervisionpath").Value
    StPath = Range("projectspath").Value
    StFullPath = StPath & "\" & Range("foldername").Value
    StNummer = Range("projectnr").Value
    StName = Range("projectname").Value
    
            With CreateObject("Scripting.FileSystemObject")
                If Not .FolderExists(StFullPath & "\") Then
                    .CreateFolder StFullPath & "\"
                           
                With Workbooks.Open(StProjectsupervision)
                    .Sheets("list of issues and projects").Cells(Rows.Count, 6).End(xlUp).Offset(1, 0).Value = StNummer
                    .Sheets("list of issues and projects").Cells(Rows.Count, 8).End(xlUp).Offset(1, 0).Value = StName
                    .Close savechanges:=True
                End With
            end if
            End With
        'application.displayalerts = false
     StFullName = StFullPath & "\" & Range("filename").Value & ".xlsm"
        ActiveWorkbook.SaveAs (StFullName)
        'application.displayalerts = true
        
    End Sub

Niels

 

[baanm]

voor elkaar!

Dank voor alle hulp. Het zit vaak in de details.
Het werkt perfect.

Groet,

Baan