sheet opslaan

[pasan]

Hallo
ik heb een code die een sheet opslaat naar een locatie met als bestandsnaam de datum van dat moment. Het gevolg is dat ik een ellenlange lijst krijgt van elke dag onder elkaar
ik wilde dit graag per jaartal in 1 mapje stoppen en in dit jaartal mapje de maand mappen


een hele tijd geleden ben ik ergens op dit forum een code tegengekomen die een excel sheet opslaat met de datum van vandaag als bestands naam, daarbij werd er gekeken of er al een map bestond met het zelfde jaartal daarna met de zelfde maand en werd de nieuwe sheet bij de juiste maand mapje toegevoegd en als het jaartal en of maand map nog niet bestond wordt deze eerst gemaakt en dan de sheet toegevoegd.

helaas kan ik dit niet terug vinden

iemand tijd om me hiermee te helpen?

 

[OctaFish]

Met deze functie kom je een heel eind...

Function CheckFolder(fldr) As Boolean
'----------------------------------------------------------------------------------
'Functie om Mappen te maken
'Kan gebruikt worden voor UNC paden, en gewone paden.
'Voorbeeldje:
'    If CheckFolder("H:\Bijlagen\WinDiff\Arie\" & Year(Date)) = True Then
'        MsgBox "De map is aangemaakt"
'    Else
'        MsgBox "De map bestond al."
'    End If
'    Msgbox CheckFolder("\\Otop01\c$\TopDesk\Truus\" & Year(Date))
'----------------------------------------------------------------------------------

Dim fs As Object
Dim folders As Variant, foldersUNC As Variant
Dim folder As String, folderUNC As String
Dim UNC As Boolean
Dim i As Integer

    folder = ""
    folderUNC = ""
    '------------------------------------------------------------------------------
    'Openen van het Scripting object <FileSystemObject>
    '------------------------------------------------------------------------------
    Set fs = CreateObject("Scripting.FileSystemObject")
    '------------------------------------------------------------------------------
    'Checken of de gevraagde map bestaat.
    '------------------------------------------------------------------------------
    If Not fs.FolderExists(fldr) Then
        '--------------------------------------------------------------------------
        'Checken of de gevraagde map een Netwerk map is of niet.
        '--------------------------------------------------------------------------
        If Left(fldr, 2) = "\\" Then
            '----------------------------------------------------------------------
            'Als de gevraagde map een Netwerk map is, dan het gesloten deel apart.
            '----------------------------------------------------------------------
            UNC = True
            foldersUNC = Split(fldr, "$\")
            foldersUNC(LBound(foldersUNC)) = foldersUNC(LBound(foldersUNC)) & "$"
            '----------------------------------------------------------------------
            'Restant van het pad splitsen in een matrix
            '----------------------------------------------------------------------
            folders = Split(foldersUNC(UBound(foldersUNC)), "\")
        Else
            '----------------------------------------------------------------------
            'Volledige pad splitsen in een matrix
            '----------------------------------------------------------------------
            folders = Split(fldr, "\")
        End If
        '--------------------------------------------------------------------------
        'Met een lus checken of de deelmappen bestaan of niet.
        '--------------------------------------------------------------------------
        For i = LBound(folders) To UBound(folders)
            '----------------------------------------------------------------------
            'Bij UNC pad het gesloten stuk er altijd voor zetten
            '----------------------------------------------------------------------
            If UNC = True Then
                folderUNC = folderUNC & folders(i) & "\"
                folder = foldersUNC(LBound(foldersUNC)) & "\" & folderUNC
            Else
                folder = folder & folders(i) & "\"
            End If
            '----------------------------------------------------------------------
            'Als de deelmap niet bestaat, dan aanmaken.
            '----------------------------------------------------------------------
            If Not fs.FolderExists(folder) Then
                fs.CreateFolder folder
                CheckFolder = True
            End If
        Next
    End If

End Function

Wel opletten: de UNC routine werkt bij mij, maar het kan zijn dat je dat deel nog moet aanpassen aan je eigen situatie.

 

[pasan]

Octafish ontzettend bedankt
ik ga hiermee aan de slag
uiteraard laat ik weten hoe dit voor mij uitpakt

 

[OctaFish]

Ik heb de code nog een beetje aangepast; ik had er niet voor niks een Boolean van gemaakt, zodat je kunt controleren of het aanmaken is gelukt of niet.

 

[pasan]

hoe laat ik jou code samen werken met de mijne?
heb geprobeerd met een call functie jou functie aan te roepen maar kreeg steeds foutmelding onvoldoende stack ruimte

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("blad1").Unprotect Password:=""
    Dim ws As Worksheet
    ActiveSheet.Copy
    Set NewWb = ActiveWorkbook
    ActiveWorkbook.SaveAs Filename:="G:\zelf gemaakte exel bestanden\24 uurs rapportage\" & Format(DateValue(Now - 8.5 / 24), "dd-mm-yyyy") & ".xls"
    With ActiveSheet.UsedRange
        .Cells.Copy
        .Cells.PasteSpecial xlPasteValues
        .Cells(1).Select
    End With
    On Error Resume Next
    ActiveSheet.DrawingObjects.Visible = True
    ActiveSheet.DrawingObjects.Delete
    On Error GoTo 0
    Application.CutCopyMode = False
    ActiveWorkbook.Save
    NewWb.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveSheet.Protect
End Sub

 

[pasan]

helaas ik kom er niet uit

 

[OctaFish]

Wat is de map die je wilt aanmaken? Ik zie in jouw voorbeeld ook nergens een verwijzing naar de functie terug...

 

[pasan]

de verwijzing zit er niet in omdat ik simpel weg geen idee heb hoe dat zou moeten.

ActiveWorkbook.SaveAs Filename:="G:\zelf gemaakte exel bestanden\24 uurs rapportage\" & Format(DateValue(Now - 8.5 / 24), "dd-mm-yyyy") & ".xls"

het excel workbook wordt naar de bovenstaande locatie opgeslagen
in deze locatie staan nog geen mappen zoals het eigenlijk de bedoeling is
dus een map van het jaar 2010 en daarin voor elke maand een map en hierin zitten dan naargelang de dagen in een maand de excel workbooks voor elke dag
zo ook voor het jaar 2011 enz
ik hoop echt dat ik het goed heb uitgelegd

 

[OctaFish]

Ik denk dat je zoiets wilt...

    strPad = "G:\zelf gemaakte exel bestanden\24 uurs rapportage\" & Year(Date)
    If CheckFolder(strPad) = True Then
        MsgBox "De map is aangemaakt"
    Else
        MsgBox "De map bestond al."
    End If
    ActiveWorkbook.SaveAs Filename:= strPad & "\" & Format(DateValue(Now - 8.5 / 24), "dd-mm-yyyy") & ".xls"

 

[pasan]

er wordt nu een map gemaakt met het jaartal
alleen in deze map is nog geen maand map

Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheets("24H Rapportage").Unprotect Password:=""
    Dim ws As Worksheet
    ActiveSheet.Copy
    Set NewWb = ActiveWorkbook
      strPad = "G:\zelf gemaakte exel bestanden\24 uurs rapportage\" & Year(Date)
    If CheckFolder(strPad) = True Then
        MsgBox "De map is aangemaakt"
    Else
        MsgBox "De map bestond al."
    End If
    ActiveWorkbook.SaveAs Filename:=strPad & "\" & Format(DateValue(Now - 8.5 / 24), "dd-mm-yyyy") & ".xls"
    
  
    With ActiveSheet.UsedRange
        .Cells.Copy
        .Cells.PasteSpecial xlPasteValues
        .Cells(1).Select
    End With
    On Error Resume Next
    Call CheckFolder(fldr)
    ActiveSheet.DrawingObjects.Visible = True
    ActiveSheet.DrawingObjects.Delete
    On Error GoTo 0
    Application.CutCopyMode = False
    ActiveWorkbook.Save
    NewWb.Close True
Application.DisplayAlerts = True
Application.ScreenUpdating = True
ActiveSheet.Protect
End Sub

deze regel "Call CheckFolder(fldr)" heeft geen onvloed de code werkt ook zonder deze regel

 

[OctaFish]

De plek waar je Call Checkfolder hebt staan is ook een hele onlogische; het opslaan van het bestand is dan al gebeurd. Bovendien heb je in een eerdere fase de map al aangemaakt. En, minstens zo belangrijk, de functie levert een Boolean antwoord terug. Daar moet je dan wel iets mee doen, en dat doe je niet. Dat gebeurt wel in de code die ik heb gegeven; een voorbeeldje overigens dat je wel kunt vervangen door jouw code als je geen behoefte hebt aan een msgbox of de map aangemaakt is of niet.
Je hebt in je vraag niet aangegeven hoe je de maanden mappen wilt aanmaken, dus daar heb ik verder niks mee gedaan. Bovendien ging ik er vanuit dat je dat zelf wel zou kunnen
De functie maakt paden aan inclusief subpaden, dus je hoeft dat niet per keer te laten uitvoeren. Zoiets bijvoorbeeld:

strPad = "G:\zelf gemaakte exel bestanden\24 uurs rapportage\" & Year(Date) & "\" & Format(Date,"mm-mmm")

Daarmee maak je submappen aan in het format 01-Jan, 02-Feb etc.

 

[pasan]

Octafish deze werkt zoals jij al wel wist maar ik niet
Mijn kennis is bij lange lange na niet voldoende om dit zelf te kunnen maken
ben niet meer dan een hobbyist die vele vele uren doorbrengt met zoeken en proberen van code maar zonder hulp van mensen zoals jij krijg ik dingen die ik nog nooit eerder geprobeerd heb in vba ook niet voor elkaar.

DUS mijn dank is groot voor je genomen moeite en het delen van je kennis TOP