• 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.

Opslaan als met datum in macro

Status
Niet open voor verdere reacties.

Roughneck

Gebruiker
Lid geworden
29 mei 2007
Berichten
83
Was hier al eerder actief voor een sorteermacro, dit is gelukt met onderstaande code, zoals je kunt zien, en ik heb een stukje code geleend uit een ander onderwerp op dit forum, (dat mag toch wel, hoop ik?) en in dze macro geplakt. De bedoeling is om het bestand automatisch te laten opslaan. Dit gaat zonder problemen, maar nu wil ik graag dat in de bestandsnaam ook de systeemdatum word ingepast, maar dan omgekeerd, dus eerst jaar, dan maand, en dan dag, dus jjjjmmdd, met nog een "hardcoded" liggend streepje (-) ervoor.

Uiteindelijk moet het resultaat van de bestandsnaam dus zoiets worden:

011101352760203-20110204.xls

Wie kan mij helpen? Oja, ik kan het voorbeeldbestand niet uploaden, want er zit een macro in?:o




Code:
Sub SorBorSav()
'
' SorBorSav Macro
' De macro is opgenomen op 04-02-2011 door Lucas.
'
' Sneltoets: CTRL+SHIFT+B
'
With Range("A3:H" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row - 1)
    .Sort Key1:=Range("B3"), Order1:=xlDescending, Header:=xlGuess
    .Interior.Color = xlNone
        With .Font
            .Name = "Verdana"
            .Size = 10
            .ColorIndex = xlAutomatic
        End With
    
    Dim Bestandsnaam As String
    Bestandsnaam$ = "G:\" + CStr(Range("c3").Value) + ".xls"
    ActiveWorkbook.SaveAs Bestandsnaam$


End With

End Sub
 
Laatst bewerkt:
Heren en dames ook,

een beetje zelfstudie heeft geleid tot de volgende code:

Code:
Sub SorBorSav()
'
' SorBorSav Macro
' De macro is opgenomen op 04-02-2011 door Lucas.
'
' Sneltoets: CTRL+SHIFT+B
'
With Range("A3:H" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row - 1)
    .Sort Key1:=Range("B3"), Order1:=xlDescending, Header:=xlGuess
    .Interior.Color = xlNone
        With .Font
            .Name = "Verdana"
            .Size = 10
            .ColorIndex = xlAutomatic
        End With
    
    Dim Bestandsnaam As String
    Dim Sysdate
    Sysdate = Format(Date, "yyyymmdd")
    Bestandsnaam$ = "G:\" + CStr(Range("c3").Value) + "-" + Sysdate + ".xls"
    ActiveWorkbook.SaveAs Bestandsnaam$


Works like a charm! Één dingetje nog, schoonheidsfoutje. Als het bestand reeds bestaat mag excel dat niet overschrijven, maar moet er de toevoeging
-2,-3,-4 enzovoort achter komen. Wie helpt me?
 
Laatst bewerkt:
verder gaan in VBA-subforum

Uiteindelijk is het resultaat van de eerste vraagstelling al bereikt, zoals je hierboven kunt lezen. Alleen omdat ik de macro per ongeluk nóg een keer uitvoerde, kwam ik in een situatie terecht, die echt opgelost zal moeten worden. Óf de macro loopt stuk, óf het reeds bestaand bestand word overschreven. Beide gevallen zijn niet acceptabel.

Na een nachtje wakker liggen:confused: heb ik een manier bedacht die zou kunnen werken, maar daar heb ik wél jullie (VBA-programmeurs) hulp bij nodig. In plaats van het programma (Excel) een naam te laten bedenken, wat misschien niet helemaal zou eenvoudig is, dacht ik dat onderstaande misschien wel een oplossing zou zijn:

wanneer het systeem ontdekt dat de bestandsnaam die bedacht is al bestaat, kan het dan een inputboxje presenteren, waarna de gebruiker zélf een toevoeging invult? Het eerste deel van de bestandsnaam, zoals ie bedacht is door de macro, moet wel gehandhaaft blijven, alleen er moet iets achter komen, bv -a, -b, of -c enzovoorts. De voorgestelde bestandsnaam moet ook afgetest worden op reeds aanwezig zijn, denk ik dan ook.

Hoe dan ook, omdat er een stukje Visual Basic om de hoek komt kijken, denk ik dat het verstandig is, om dit bericht ook te gaan plaatsen in dát subforum. Waarvan akte.
 
Laatst bewerkt:
deze gaat zelf nummering toevoegen, het stukje voor Sysdate moet je maar naar jouw situatie aanpassen
Code:
Sub xxx()
  Dim Bestandsnaam As String
  Dim Sysdate
  Sysdate = Format(Date, "yyyymmdd")
  tel = 0
  Do
    Bestandsnaam$ = ThisWorkbook.Path & "\" & Sysdate & IIf(tel = 0, "", "(" & tel & ")") & ".xls"  'bestand noemt straks zo
    If Dir(Bestandsnaam$) = "" Then                        'bestaat die naam al in die directory ?
      ActiveWorkbook.SaveAs Bestandsnaam$                  'zo niet saven
      tel = 0                                              'teller op 0 zetten om uit de loop te komen
    Else
      tel = tel + 1                                        'bestand bestond al, dus teller 1 ophogen
    End If
  Loop While tel <> 0
End Sub
 
Laatst bewerkt:
Zó Cow18, je hebt misschien wel een simpele oplossing voor een lastig probleem bedacht.

Ik was al verder, met een dialoogbox, en zo, maar dit is misschien wel geniaal.
Kan de teller gebruikt worden, om de bestandsnamen aan te passen met een -a, -b enzovoorts? Dan is de dialoogbox niet meer nodig, namelijk.

Uiteindelijk zou het rijtje bestandsnamen er zo moeten uitzien:

  1. 011101352760909-20110205
  2. 011101352760909-20110205-a
  3. 011101352760909-20110205-b
  4. 011101352760909-20110205-c
  5. 011101352760909-20110205-d

Note: de toevoeging met de letters heb ik niet zelf bedacht. Die komen uit de organisatie, en zullen zo hun bedoeling hebben.
 
Laatst bewerkt:
Test deze eens
Code:
Sub xxx()
  Dim Bestandsnaam As String
  Dim Sysdate
  Sysdate = Format(Date, "yyyymmdd")
  tel = 96
  Do
    Bestandsnaam$ = ThisWorkbook.Path & "\" & [A1] & "-" & Sysdate & IIf(tel = 96, "", "-" & Chr(tel)) & ".xls"   'bestand noemt straks zo
    If Dir(Bestandsnaam$) = "" Then                        'bestaat die naam al in die directory ?
      ActiveWorkbook.SaveAs Bestandsnaam$                  'zo niet saven
      tel = 96                                              'teller op 0 zetten om uit de loop te komen
    Else
      tel = tel + 1                                        'bestand bestond al, dus teller 1 ophogen
    End If
  Loop While tel <> 96
End Sub
 
als je gebruik maakt van de kolommen kan je in excel2003 gemakkelijk tot 256 opeenvolgende kopien maken, in excel2007 nog veel meer.
Code:
Sub xxx()
  Dim Bestandsnaam As String
  Dim Sysdate
  Dim tel As Integer, Letter As String
  Sysdate = Format(Date, "yyyymmdd")
  tel = 0
  Do
    If tel > 0 Then
      Letter = "-" & LCase(Replace(Left(Cells(1, tel).Address, 3), "$", "")) 'vertaal teller naar een kolomletter
    Else
      Letter = ""
    End If
    Bestandsnaam$ = ThisWorkbook.Path & "\" & [A1] & "-" & Sysdate & Letter & ".xls"  'bestand noemt straks zo
    If Dir(Bestandsnaam$) = "" Then                        'bestaat die naam al in die directory ?
      ActiveWorkbook.SaveAs Bestandsnaam$                  'zo niet saven
      tel = 0                                              'teller op 0 zetten om uit de loop te komen
    Else
      tel = tel + 1                                        'bestand bestond al, dus teller 1 ophogen
    End If
    If tel > Columns.Count Then MsgBox "groot probleem": Exit Sub
  Loop While tel <> 0
End Sub
 
Bijna opgelost, heren...

Cow18, hardstikke bedankt voor je code, dat gaat echt bijna helemaal goed. Ik heb nog 3 kleine vraagjes, maar eerst zet ik hier even de volledige macro neer, dan weten we weer waar we het over hebben.


Code:
Sub SorBorSav()
'
' SorBorSav Macro
' De macro is opgenomen op 04-02-2011 door Lucas.
'
' Sneltoets: CTRL+SHIFT+B
'
With Range("A3:H" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row - 1)
    .Sort Key1:=Range("B3"), Order1:=xlDescending, Header:=xlGuess
    .Interior.Color = xlNone
        With .Font
            .Name = "Verdana"
            .Size = 10
            .ColorIndex = xlAutomatic
        End With
    
    Dim Bestandsnaam As String
  Dim Sysdate
  Dim tel As Integer, Letter As String
  Sysdate = Format(Date, "yyyymmdd")
  tel = 0
  Do
    If tel > 0 Then
      Letter = "-" & LCase(Replace(Left(Cells(1, tel).Address, 3), "$", "")) 'vertaal teller naar een kolomletter
    Else
      Letter = ""
    End If
    Bestandsnaam$ = ThisWorkbook.Path & "\" & [C3] & "-" & Sysdate & Letter & ".xls"  'bestand noemt straks zo
    If Dir(Bestandsnaam$) = "" Then                        'bestaat die naam al in die directory ?
      ActiveWorkbook.SaveAs Bestandsnaam$                  'zo niet saven
      tel = 0                                              'teller op 0 zetten om uit de loop te komen
    Else
      tel = tel + 1                                        'bestand bestond al, dus teller 1 ophogen
    End If
    If tel > Columns.Count Then MsgBox "groot probleem": Exit Sub
  Loop While tel <> 0

End With

End Sub

Cow18, lache, die messagebox, maar zover gaan we nooit komen hoor, hoop ik. Als er 5 bestanden komen op dezelfde dag voor dezelfde werkgever, is het veel. Maar het opslaan werkt prima, zoals ik me dat voorgesteld had.

Echter de macro slaat het bestand op in dezelfde map, als waar het invoerbestand vandaan komt. Ik denk dat ThisWorkbook.Path & "\" daarvoor verantwoordelijk is. Hier moet echt een vaste driveletter en map worden geplaatst.
Ik denk dat me dat moet lukken.

komen we op het tweede punt, thuis gebruik ik Office 2010, op het werk zijn we nog bezig met het antieke Office 2003. Gaat deze code daar ook werken, denk je?

Verder wil ik iedereen bedanken die hier zijn knowhow in heeft willen stoppen. Super, mensen, nogmaals bedankt.;)

Dan nog dit, en dat is voor iedereen hier. Ik ben zóóó gemakzuchtig bezig geweest hier, ik schaam me er eigenlijk een beetje voor. Wat ik natuurlijk graag zou willen is zelf die code bedenken. Hoe komen we op dat punt? Zijn jullie "self-made", of zijn er cursussen gevolgd, boeken gelezen misschien? Welk padje moet ik volgen, zijn daar nog tips voor?
 
Laatst bewerkt:
wat aanpassingen
die rode colorindex ipv color, anders vind 2003 dat vermoedelijk niet goed

Bovenin de module staan nu wat vaste paramaters. Op die manier weet excel of je thuis of op het werk bent. Je gebruikt je username via application of via environ en vergelijk die met de parameter die je vastlegde in ThuisUser. Zo weet excel dan of hij de ThuisDir of de WerkDir moet pakken.

Eens je die username kent, mogen die 2 Msgboxes weg.

Code:
Option Explicit
Const ThuisUser = "BS"
Const Thuisdir = "C:\data\excell\forum\"
Const Werkdir = "G:\MijnDocumenten"

Sub SorBorSav()
'
' SorBorSav Macro
' De macro is opgenomen op 04-02-2011 door Lucas.
'
' Sneltoets: CTRL+SHIFT+B
'
  Dim Bestandsnaam As String, MyDir As String
  Dim Sysdate
  Dim tel As Integer, Letter As String



  With Range("A3:H" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row - 1)
    .Sort Key1:=Range("B3"), Order1:=xlDescending, Header:=xlGuess
    .Interior.[COLOR="red"]ColorIndex[/COLOR] = xlNone                          'colorindex voor 2003 !!!!
    With .Font
      .Name = "Verdana"
      .Size = 10
      .ColorIndex = xlAutomatic
    End With

    MsgBox "op deze PC is de username " & vbTab & Application.UserName
    MsgBox "op deze PC is de environ-username " & vbTab & Environ("username")
    MyDir = IIf(Application.UserName = ThuisUser, Thuisdir, Werkdir)
    MyDir = MyDir & IIf(Right(MyDir, 1) <> "\", "\", "")

    Sysdate = Format(Date, "yyyymmdd")
    tel = 0
    Do
      If tel > 0 Then
        Letter = "-" & LCase(Replace(Left(Cells(1, tel).Address, 3), "$", ""))  'vertaal teller naar een kolomletter
      Else
        Letter = ""
      End If
      Bestandsnaam$ = MyDir & [C3] & "-" & Sysdate & Letter & ".xls"  'bestand noemt straks zo
      If Dir(Bestandsnaam$) = "" Then                      'bestaat die naam al in die directory ?
        ActiveWorkbook.SaveAs Bestandsnaam$                'zo niet saven
        tel = 0                                            'teller op 0 zetten om uit de loop te komen
      Else
        tel = tel + 1                                      'bestand bestond al, dus teller 1 ophogen
      End If
      If tel > Columns.Count Then MsgBox "groot probleem": Exit Sub
    Loop While tel <> 0

  End With

End Sub
 
hahaha, Cow81, jij was nog niet tevreden hè?:shocked: Ik zal m eens gaan proberen. Meer code, meer e-learning voor mij. Maar je mag nu wel stoppen, hoor. Ga maar lekker voetbal kijken, haha, net als ik.:):):)
 
messagebox ingebouwd

Hoi, ik heb een beetje zitten spelen met de code van Cow18, en kwam tot het volgende, waarbij een messagebox is ingebouwd, die de gebruiker een seintje geeft dat het bestand succesvol is opgeslagen, met een kleine herinnering daarbij. (printen) Wel zo netjes, vind ik.

Hoe krijg ik de 2e zin van de messagebox op de 2e regel? Gewoon een hoop spaties inbouwen, of is er een andere manier?

En na enig nadenken kwam het volgende bij me op. Het bestand word geopend en aangepast, en niets dat de gebruiker ervan weerhoud om buiten de macro het bestand op te slaan. Kan die functie tijdelijk worden uitgeschakeld, totdat de macro gebruikt word, en na beeindiging weer ingeschakeld worden?

Hier is de code:

Code:
Sub SorBorSav()
'
' SorBorSav Macro
' De macro is opgenomen op 04-02-2011 door Lucas.
'
' Sneltoets: CTRL+SHIFT+B
'
With Range("A3:H" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row - 1)
    .Sort Key1:=Range("B3"), Order1:=xlDescending, Header:=xlGuess
    .Interior.Color = xlNone
        With .Font
            .Name = "Verdana"
            .Size = 10
            .ColorIndex = xlAutomatic
        End With
    
    Dim Bestandsnaam As String
  Dim Sysdate
  Dim tel As Integer, Letter As String
  Sysdate = Format(Date, "yyyymmdd")
  tel = 0
  Do
    If tel > 0 Then
      Letter = "-" & LCase(Replace(Left(Cells(1, tel).Address, 3), "$", "")) 'vertaal teller naar een kolomletter
    Else
      Letter = ""
    End If
    Bestandsnaam$ = "G:\" & [C3] & "-" & Sysdate & Letter & ".xls"  'bestand noemt straks zo
    If Dir(Bestandsnaam$) = "" Then                        'bestaat die naam al in die directory ?
      ActiveWorkbook.SaveAs Bestandsnaam$                  'zo niet saven
      
      MsgBox "Het bestand              " & "'" & [C3] & "-" & Sysdate & Letter & "'" & "              is opgeslagen" & " , vergeet niet nog uit te printen"
             
             
      tel = 0                                              'teller op 0 zetten om uit de loop te komen
    Else
      tel = tel + 1                                        'bestand bestond al, dus teller 1 ophogen
    End If
    If tel > Columns.Count Then MsgBox "Paniek": Exit Sub
  Loop While tel <> 0

End With

End Sub
 
Laatst bewerkt:
Voor je tweede regel:
Code:
MsgBox "Het bestand              " & "'" & [C3] & "-" & Sysdate & Letter & "'" & "              is opgeslagen" [COLOR="red"]& Chr(10) &[/COLOR] "vergeet niet nog uit te printen"
 
Dank je wel, HSV.

Ik heb ook dit kunnen toepassen. Staat HSV soms voor Heilooer Sport Vereniging?:thumb:

Maar ik ben nog verder gegaan. Ik heb de hele macro nu onder een knop gezet. Klein detail, he? Macro word nu niet geactiveerd met CTRL+Shift+B, maar dmv deze knop. Kicken man.
 
Laatst bewerkt:
Leuk hoor zo'n knop in je Excel-bestand, maar als ik het bestandje ga printen, dan print ie ook deze knop uit. Is daar nog een handigheidje voor? Ik kan m wel buiten het printbereik neerzetten, maar dan hangt die knop er maar zo'n beetje bij. vind ik niet echt mooi.
Mocht het niet anders kunnen moet ik misschien weer terug naar de toetscombinatie
 
Laatst bewerkt:
je knop selecteren naar eigenschappen gaan en daar bij printobject op false zetten
 
Cow18, je krijgt een hele grote virtuele taart van mij, man.:d Ik hoop dat er nog eens een dag komt, dat ik dit zelf kan verzinnen:thumb:
 
bij opslaan check of er iets gewijzigd is

Voor de slagroom op de taart: Het is in principe mogelijk om een aantal keer achter elkaar op de macroknop te drukken, bijvoorbeeld als iemand zit te kletsen en dus niet meer weet of ie het bestand nou had opgeslagen of niet, maar komt er steeds een bestandje bij, met dezelfde inhoud, maar met een andere naam.

Weet iemand hier raad mee?



En zo komen we steeds tot een nog beter product hoop ik.
 
minder kletsen

hier en daar wat aanpassingen
Code:
Sub SorBorSav()
'
' SorBorSav Macro
' De macro is opgenomen op 04-02-2011 door Lucas.
'
' Sneltoets: CTRL+SHIFT+B
'

  Dim Bestandsnaam As String
  Dim Sysdate
  Dim tel As Integer, Letter As String
  [COLOR="red"]Dim lastSaved As Date, antw As Integ[/COLOR]er
  Sysdate = Format(Date, "yyyymmdd")
  tel = 0
  Do
    If tel > 0 Then
      Letter = "-" & LCase(Replace(Left(Cells(1, tel).Address, 3), "$", ""))  'vertaal teller naar een kolomletter
    Else
      Letter = ""
    End If
    Bestandsnaam$ = "G:\" & [C3] & "-" & Sysdate & Letter & ".xls"  'bestand noemt straks zo
    If Dir(Bestandsnaam$) = "" Then                        'bestaat die naam al in die directory ?
      
      [COLOR="red"]If tel > 0 And Now - lastSaved < TimeValue("5:00") Then 'in de laatste 5 minuten opgeslagen ?
        antw = MsgBox("je hebt nog maar opgeslagen om " & Format(lastSaved, "hh:mm:ss"), vbYesNo, "Opnieuw opslaan ?????")
      Else
        antw = vbYes
      End[/COLOR] If
      
     [COLOR="red"] If antw = vbYes [/COLOR]Then
        ActiveWorkbook.SaveAs Bestandsnaam$                'zo niet saven
        MsgBox "Het bestand              " & "'" & [C3] & "-" & Sysdate & Letter & "'" & "              is opgeslagen" & " , vergeet niet nog uit te printen"
      [COLOR="red"]End [/COLOR]If
      tel = 0                                              'teller op 0 zetten om uit de loop te komen
    Else
      tel = tel + 1                                        'bestand bestond al, dus teller 1 ophogen
      [COLOR="red"]lastSaved = FileDateTime(Bestandsnaam[/COLOR]$)
    End If
    If tel > Columns.Count Then MsgBox "Paniek": Exit Sub
  Loop While tel <> 0
End Sub
 
Laatst bewerkt:
Hoi Cow18, ik zal je code weer inbouwen, maar al ik het goed zie is dit een tijds check, zou er ook een manier zijn om de inhoud te vergelijken op wijzigingen?

Ik merk dat ik steeds weer andere dingen bedenk, die de idiot-proefheid van het bestand kunnen verbeteren, ik heb geen idee wat er allemaal mogelijk is op deze manier, maar ik hoop dat je het nog leuk vind?

Zo heb je dus net bedacht om de Macro-knop niet op de print af te beelden, bedenk ik weer dat het helemaal mooi zou zijn om de macroknop ook niet mee te saven, als het ware. Als ik moet stoppen moet je het zeggen hoor.

Ik probeer op het werk de zin van Macro's aan te tonen, maar dan moeten ze het niet onderuit kunnen halen, door wat zij vinden tekortkomingen aan te tonen. Ze zijn beslist niet ondankbaar hoor, begrijp me niet verkeerd, maar het plaatje moet gewoon kloppen.

De aangepaste code zoals ie nu is:


Code:
Private Sub Opslaan_Click()

'
'
With Range("A3:H" & ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row - 1)
    .Sort Key1:=Range("B3"), Order1:=xlDescending, Header:=xlGuess
    .Interior.ColorIndex = 0
    .HorizontalAlignment = xlGeneral
    .VerticalAlignment = xlBottom
        With .Font
            .Name = "Verdana"
            .Size = 10
            .ColorIndex = xlAutomatic
            
        End With
        
        
    If Range("C3").Value = "" Then
       a = MsgBox("U heeft niets ingevuld in Cel C3", vbOKOnly)
       Exit Sub
    End If
    
    
    Dim Bestandsnaam As String
  Dim Sysdate
  Dim tel As Integer, Letter As String
    Dim lastSaved As Date, antw As Integer
  Sysdate = Format(Date, "yyyymmdd")
  tel = 0
  Do
    If tel > 0 Then
      Letter = "-" & LCase(Replace(Left(Cells(1, tel).Address, 3), "$", "")) 'vertaal teller naar een kolomletter
    Else
      Letter = ""
    End If
    Bestandsnaam$ = "G:\" & [C3] & "-" & Sysdate & Letter & ".xls"  'bestand noemt straks zo
    If Dir(Bestandsnaam$) = "" Then                        'bestaat die naam al in die directory ?
    
    
    If tel > 0 And Now - lastSaved < TimeValue("5:00") Then 'in de laatste 5 minuten opgeslagen ?
        antw = MsgBox("Je hebt om " & Format(lastSaved, "hh:mm:ss") & " uur al eens opgeslagen", vbYesNo, "  Opnieuw opslaan ?????")
      Else
        antw = vbYes
      End If
      
      If antw = vbYes Then
      ActiveWorkbook.SaveAs Bestandsnaam$                  'zo niet saven
      
      MsgBox "Het bestand              " & "'" & [C3] & "-" & Sysdate & Letter & "'" & "              is opgeslagen." & Chr(10) & Chr(10) & "Vergeet niet nog uit te printen!"
      End If
             
      tel = 0                                              'teller op 0 zetten om uit de loop te komen
    Else
      tel = tel + 1                                        'bestand bestond al, dus teller 1 ophogen
    lastSaved = FileDateTime(Bestandsnaam$)
    End If
    If tel > Columns.Count Then MsgBox "Paniek": Exit Sub
  Loop While tel <> 0

End With


End Sub
 
Laatst bewerkt:
Over het meekopieeren van de commandbutton:

Na lang zoeken, heb helemaal rode oogjes, heb ik de volgende VB line gevonden.

.Application.CopyObjectsWithCells = False

Ik heb m al geprobeerd, maar zonder resultaat. Wie weet hoe dit komt? Ik heb m op diverse plaatsen in de code gezet.:shocked:
 
Status
Niet open voor verdere reacties.
Terug
Bovenaan Onderaan