• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Andere map opslaan

Status
Niet open voor verdere reacties.
M

monty1a

Gebruiker
Lid geworden
29 dec 2006
Berichten
202
Hallo,

Ik heb een vraag over opslaan.
ik sla nu middels een macro als volgt een sheet op:
Code: 
Sub Planning_opslaan()

If MsgBox("U gaat nu het tabblad als nieuw bestand opslaan!" & vbCr & vbCr & "Wilt u doorgaan?", vbOKCancel + vbQuestion, "Let op!") = vbCancel Then Exit Sub
Application.DisplayAlerts = False
  ar = ThisWorkbook.Sheets("Planning").Range("A2:M350")

  Dim c00 As String, c01 As String
  c00 = ThisWorkbook.Path & "\" & Replace([D1], "\", "") & "\"
  c01 = [B1]
  With CreateObject("Scripting.FileSystemObject")
    If Not .FolderExists(c00) Then .CreateFolder c00
  End With
  Sheets("Planning").Copy
  With ActiveWorkbook
  .Sheets(1).Range("A2:M350").Value = ar
    .SaveAs c00 & c01 & ".xlsx", 51
  End With


Application.DisplayAlerts = True
End Sub

Dit werkt in principe perfect, maar ik zou graag willen dat hij in een andere map opslaat.

Nu wordt het bijvoorbeeld opgeslagen op : V:/.....(variënd)/...(variënd)/2. Projectducumenten uitvoering/ en deze moet 1 map terug naar V:/.....(variënd)/...(variënd)/7. Testrapporten/
Is dit mogelijk omdat de voorgaande mappen ieder bestand variërend zijn?

Thanx
 
Je kan de macro eerst laten vragen middels Application.FileDialog(msoFileDialogFolderPicker) waar het bestand moet worden opgeslagen.
 
Laatst bewerkt:
Die oplossing is ook perfect, maar hoe kan ik die in de bovenstaande code verwerken?
Die code hierboven heb ik namelijk ook bij elkaar gesprokkeld en heel veel verstand van VBA heb ik nog niet.

Thanx
 
Zet deze functie onder je Sub Planning_opslaan, dus na de End Sub er van:
Code: 
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function

In plaats van ThisWorkbook.Path in de Sub Planning_Opslaan gebruik je dan GetFolder
 
Sorry maar ik begrijp het niet helemaal.

Dus de code komt er dan zo uit te zien?
Code: 
Sub Testresultaten_opslaan()

If MsgBox("U gaat nu het tabblad als nieuw bestand opslaan!" & vbCr & vbCr & "Wilt u doorgaan?", vbOKCancel + vbQuestion, "Let op!") = vbCancel Then Exit Sub
Application.DisplayAlerts = False
  ar = ThisWorkbook.Sheets("Planning").Range("A2:M350")

  Dim c00 As String, c01 As String
  c00 = GetFolder & "\" & Replace([D1], "\", "") & "\"
  c01 = [B1]
  With CreateObject("Scripting.FileSystemObject")
    If Not .FolderExists(c00) Then .CreateFolder c00
  End With
  Sheets("Planning").Copy
  With ActiveWorkbook
  .Sheets(1).Range("A2:M350").Value = ar
    .SaveAs c00 & c01 & ".xlsx", 51
  End With


Application.DisplayAlerts = True
End Sub
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function

De folder maakt hij wel netjes aan, maar met opslaan gaat het fout bij CreateFolder c00

Dit gaat in ieder geval niet goed.
Ik doe iets niet goed maar wat....
 
Laatst bewerkt:
Als c00 dan een pad bevat die uit meerdere folders bestaat zal je die folders per stuk moeten controleren en eventueel aanmaken.

Daarnaast, als je aangeeft dat er iets fout gaat zal je daar ook een foutmelding bij krijgen en is dan het eerste dat je er bij moet vertellen.
 
Sorry, maar hij doet het nu gewoon, dus waarschijnlijk heb ik gisteren iets verkeerd gedaan.

Super bedankt.
 
Ok dan :)
 
Mag ik nog 1 vraagje stellen?

Om ff te pietlutten.
Hoe kan ik het instellen dat hij het nieuwe aangemaakte bestand gelijk sluit en het tabblad in het originele bestand verbergt?

Code: 
If MsgBox("U gaat nu het tabblad als nieuw bestand opslaan!" & vbCr & vbCr & "Wilt u doorgaan?", vbOKCancel + vbQuestion, "Let op!") = vbCancel Then Exit Sub
Application.DisplayAlerts = False
  ar = ThisWorkbook.Sheets("Testresultaten").Range("A2:Q350")

  Dim c00 As String, c01 As String
  c00 = GetFolder & "\" & Replace([D1], "\", "") & "\"
  c01 = [B1]
  With CreateObject("Scripting.FileSystemObject")
    If Not .FolderExists(c00) Then .CreateFolder c00
  End With
  Sheets("Testresultaten").Copy
  With ActiveWorkbook
  .Sheets(1).Range("A2:Q350").Value = ar
    .SaveAs c00 & c01 & ".xlsx", 51
  End With

Application.DisplayAlerts = True
End Sub
Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show = -1 Then sItem = .SelectedItems(1)
    End With
    GetFolder = sItem
    Set fldr = Nothing
End Function

thanx
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan