Opslaan als (waarde v.e. cel), indien naam aanwezig hier een volgnummer aan toevoegen

Robert Smidt · 17 jan 2011

Hallo beste mensen,

Ik ben op zoek naar een code (vba excel zie vb) voor mijn probleem.

Op zich werkt onderstaande code prima. Ik zal even uitleggen wat deze code doet:
Het systeem kijkt in cel d2 of daar een e-mailadres staat; zo ja dan slaat het systeem het bestand onder deze naam op. Mocht deze niet zijn gevuld, dan vraagt het systeem een e-mailadres handmatig in te vullen en slaat deze vervolgens op.

Nu blijkt in de praktijk dat soms het bestand al voorkomt in het pad waar deze opgeslagen moet worden (mag niet worden overschreven). Mijn verzoek is daarom; wie kan mij helpen aan de code die kijkt of het bestand al aanwezig is en zo ja hier een volgnummer (in cel d2) aan toevoegt bijv.: Robertsmidt@hotmail.com bestaat al, het systeem maakt hier vervolgens van: Robertsmidt@hotmail.com 01 (let op met spatie er voor), bestaat deze echter ook al, dan wordt het: Robertsmidt@hotmail.com 02 enz. vervolgens moet deze het bestand onder de nieuwe naam (vanuit d2) opslaan.

Alvast hartelijk bedankt.

Groet, Robert

Code:

Sub opslaanals()

' De macro is opgenomen op 7-11-2010 door Robert Smidt.
'

If [d2] <> "" Then
    Rem Aplication.ScreenUpdating = False
    Sheets("Blad1").Copy
    With ActiveWorkbook
        .SaveAs "C:\Documents and Settings\smidr00\Bureaublad\Bos\Gereed voor verrijking\" & CStr(Range("d2").Value) & ".xls"
                .Close
    End With
    Application.ScreenUpdating = True
Else
    t = InputBox("Helaas staat het e-mailadres van de GDW niet in het bestand; vul deze alsnog handmatig in!")
    ActiveSheet.Range("d2").Select
    ActiveCell.FormulaR1C1 = t
    Sheets("Blad1").Copy
    With ActiveWorkbook
        .SaveAs "C:\Documents and Settings\smidr00\Bureaublad\Bos\Gereed voor verrijking\" & CStr(Range("d2").Value) & ".xls"
        Rem .SaveAs "Q:\VBPROW57\nfs_hvx\113\Emmen Toeslagen BOD\Te verrijken infoverzoeken\" & CStr(Range("d2").Value) & ".xls"
        .Close
    End With
    Application.ScreenUpdating = True
    Rem MsgBox ("Het bestand is opgeslagen onder de door u opgevoerde bestandsnaam!")
End If

HSV · 17 jan 2011

Ik weet niet of het kan wat jij wil in Excel.

Mocht er niemand een suggestie hebben, dan is dit misschien een idee.

Schrijf elk opgeslagen bestandsnaam naar een apart blad.

Zet in bv. cel E2 deze formule:

Code:

=D2&" "&AANTAL.ALS('Blad4'!A1:A1000;D2)+1

En schrijf dan cel E2 weg i.p.v. D2.

Mark xl · 18 jan 2011

Beste Robert,

Natuurlijk is dat mogelijk

Plak onderstaande code maar in een module

Ik heb de code verdeeld over meerdere procedures zodat het overzichtelijk blijft wat er gebeurt.
hopelijk helpt dit je verder

Code:

Option Explicit

Sub OpslaanAls()

    Application.ScreenUpdating = False

    If Range("D2") = "" Then
    
        Range("D2") = InputBox( _
            "Helaas staat het e-mailadres van de GDW niet in het " & _
            "bestand; vul deze alsnog handmatig in!")
    
    End If
    
    SaveToFile Sheets("Blad1"), CStr(Range("D2").Value)

    Application.ScreenUpdating = True

End Sub

Private Sub SaveToFile(ByRef Mysheet As Worksheet, _
                        ByVal sFile As String)

    If sFile <> "" Then

        sFile = NewFileName(sFile)
        Mysheet.Copy
        
        With ActiveWorkbook
        
            .SaveAs sFile & ".xls"
            .Close
            
        End With
        
    End If
    
End Sub

Private Function NewFileName(ByVal sName As String) As String

Const spath As String = _
    "C:\Documents and Settings\smidr00\Bureaublad\Bos\Gereed voor verrijking\"
Dim lIndex As Long
    
    sName = spath & sName & "00"
    
    Do While Dir(sName & ".xls") <> ""
    
        lIndex = lIndex + 1
        sName = Mid(sName, 1, Len(sName) - 2) & _
                    Right("00" & CStr(lIndex), 2)
    
    Loop

    NewFileName = sName

End Function

Nog wat tips:

- Gebruik Range("D2") voor cel adres verwijzingen ipv blokhaken.
- probeer niet twee keer dezelfde code te gebruiken zoals je in jouw procedure doet. Dat helpt bij het onderhouden van je code

Warme bakkertje · 18 jan 2011

@ Mark XL

Gebruik Range("D2") voor cel adres verwijzingen ipv blokhaken.

En om welke reden dan wel ?

Mark xl · 18 jan 2011

Bij een shape verwijzing gebruik je Shape("myshape")
Bij een worksheet verwijzing gebruik je sheet("mysheet")
Bij een Range verwijzing gebruik je dan liever Range("myrange")

Het is altijd direct duidelijk dat je naar een object verwijst, en dat je geen evaluatie uitvoert.

blokhaken voegen niets aan je code toe, dus dan zou ik netjes Range("") blijven gebruiken.

Robert Smidt · 18 jan 2011

reactie

Hartelijk bedankt voor de snelle reactie, goed te horen dat er toch een mogelijkheid is.

Ik heb de code geprobeerd echter geeft deze een foutmelding bij:
.SaveAs sFile & ".xls"

.Close

Wellicht heb ik iets fout gedaan.

Bovendien werken ik op het werk nog met de 97-versie en zal deze naar alle waarschijnlijkheid het ook niet doen, toch?

Mark xl · 19 jan 2011

Hallo Robert,

Wat voor foutmelding krijg je?
Dat is belangrijk om de oorzaak te achterhalen.

Is de map ongeldig? of is er een andere melding.

Ik heb overigens niet je verzoek in post #1 gehonoreerd om een spatie tussen de bestandsnaam en het nummer te plaatsen.

Dus bij deze hier de code inclusief je " 01.xls", " 02.xls" verzoek.

Code:

Option Explicit

Sub OpslaanAls()

    Application.ScreenUpdating = False

    If Range("D2") = "" Then
    
        Range("D2") = InputBox("Helaas staat " & _
            "het e-mailadres van de GDW niet in het " & _
            "bestand; vul deze alsnog handmatig in!")
    
    End If
    
    SaveToFile Sheets("Blad1"), CStr(Trim(Range("D2").Value))

    Application.ScreenUpdating = True

End Sub

Private Sub SaveToFile(ByRef Mysheet As Worksheet, _
                        ByVal sFile As String)

    If sFile <> "" Then

        sFile = NewFileName(sFile) & ".xls"
        Mysheet.Copy
        
        With ActiveWorkbook
                
            .SaveAs sFile
            .Close
            
        End With
        
    End If
    
End Sub

Private Function NewFileName(ByVal sName As String) As String

Const spath As String = _
    "C:\Documents and Settings\smidr00\Bureaublad\Bos\Gereed voor verrijking\"
'Const sPath As String = "C:\Temp\"

Dim lIndex As Long
    
    sName = spath & sName & "   "
    
    Do While Dir(Trim(sName) & ".xls") <> ""
    
        lIndex = lIndex + 1
        sName = Mid(sName, 1, Len(sName) - 3) & " " & _
                    Right("00" & CStr(lIndex), 2)
    
    Loop

    NewFileName = Trim(sName)

End Function

Robert Smidt · 19 jan 2011

super

Het werkt perfect super bedankt. Ik vind het altijd weer knap dat jullie oplossingen aan kunnen dragen. CHAPEAU

Thuis werk ik met 2003 versie, echter op het werk nog steeds met '97, ik ben bang dat onderstaande coderegel niet werkt. Mocht dat juist zijn wat is dan het alternatief?

Private Function NewFileName(ByVal sName As String) As String

Nogmaals bedankt.

Ps ik heb een tweede vraag gesteld echter nog geen antwoord, volgens mij is die vraag op lange na niet zo ingewikkeld als deze, mochten jullie hier naar willen kijken dan heel graag. Het betreft een vraag over het sorteren van een werkblad over meerdere werkbladen.

Mark xl · 20 jan 2011

Hoi Robert, ik ben blij dat het werkt.

Ik wil je nogmaals vragen wat de foutmelding is die je krijgt bij de door jou opgegeven coderegel. dan weet ik misschien wat de oorzaak van de fout is.

ik heb nog even gekeken, en twee keer krijg je een foutmelding bij een samenvoeg teken ( "&" )
Misschien dat dit wel werkt in Excel 97. ik kan daar helaas niet mee testen.

Code:

Option Explicit

Sub OpslaanAls()

    Application.ScreenUpdating = False

    If Range("D2") = "" Then
    
        Range("D2") = InputBox("Helaas staat " & _
            "het e-mailadres van de GDW niet in het " & _
            "bestand; vul deze alsnog handmatig in!")
    
    End If
    
    SaveToFile Sheets("Blad1"), CStr(Trim(Range("D2").Value))

    Application.ScreenUpdating = True

End Sub

Private Sub SaveToFile(ByRef Mysheet As Worksheet, _
                        ByVal sFile As String)

    If sFile <> "" Then

        sFile = NewFileName(sFile)
        Mysheet.Copy
        
        With ActiveWorkbook
                
            .SaveAs sFile
            .Close
            
        End With
        
    End If
    
End Sub

Private Function NewFileName(ByVal sName As String) As String

Const spath As String = _
    "C:\Documents and Settings\smidr00\Bureaublad\Bos\Gereed voor verrijking\"
'Const sPath As String = "C:\Temp\"

Dim lIndex As Long
    
    sName = spath & sName & "   "
    
    Do While Dir(Trim(sName) & ".xls") <> ""
    
        lIndex = lIndex + 1
        sName = Mid(sName, 1, Len(sName) - 3) & " " & _
                    Right("00" & CStr(lIndex), 2)
    
    Loop

    sName = sName & ".xls"
    NewFileName = Trim(sName)

End Function

Robert Smidt · 21 jan 2011

werkt prima, ook onder excel 97

Zojuist op het werk uitgeprobeerd en de macro geeft geen foutmelding, dus helaas kan ik je die ook niet meer geven. Ik ben ontzettend blij met jouw oplossing, ik was daar echt zelf nooit opgekomen. Nogmaals bedankt.

Wat ik nog wel graag zou weten of het mogelijk is de data vanuit ander bestand ingelezen kan worden vanuit voornoemde sjabloon. Even voor jouw beeld: ik ontvang een excelbestand via de mail die ik heb geopend, nu wil ik met het sjabloon de data vanuit het geopende bestand inlezen en kopiëren naar het sjabloon. Omdat dit bestand nog geen naam heeft kun je hiervoor moeilijk een code bedenken. Daarom denk ik dat de macro moet kijken welk bestand open staat en daar alle data vanuit kopieert. Ik begrijp dat je meerdere bestanden open kunt hebben staan en waar moet de macro dan naar kijken. In dat geval denk naar het bestand wat het laatst is geopend.

Ik weet dat je voor nieuwe vragen een nieuwe topic moet openen maar aangezien jij perfect op de hoogte bent hoe de macro bestanden wegzet wil ik je toch vragen of het kan en zo ja welke code hiervoor te gebruiken is.

Nogmaals ontzettend bedankt voor de oplossing

Robert Smidt · 21 jan 2011

na testen probleem ontdekt

Hoi Mark,

De methode om de e-mailadressen te voorzien van een volgnummer werkt zoals gezegd perfect, echter ben ik vergeten te vertellen dat de bestandsnaam - met het daar aan gekoppelde volgnummer - in cel E2 moet zetten. Is dat mogelijk?

Ik hoor heel graag van jou.

Groet, Robert

Mark xl · 21 jan 2011

Robert Smidt zei:
echter ben ik vergeten te vertellen dat de bestandsnaam - met het daar aan gekoppelde volgnummer - in cel E2 moet zetten.

Hoi Robert,

Verander

Code:

Sub OpslaanAls()

    Application.ScreenUpdating = False

    If Range("D2") = "" Then
    
        Range("D2") = InputBox("Helaas staat " & _
            "het e-mailadres van de GDW niet in het " & _
            "bestand; vul deze alsnog handmatig in!")
    
    End If
    
    SaveToFile Sheets("Blad1"), CStr(Trim(Range("D2").Value))

    Application.ScreenUpdating = True

End Sub

in

Code:

Sub OpslaanAls()

    Application.ScreenUpdating = False

    If Range("E2") = "" Then
    
        Range("E2") = InputBox("Helaas staat " & _
            "het e-mailadres van de GDW niet in het " & _
            "bestand; vul deze alsnog handmatig in!")
    
    End If
    
    SaveToFile Sheets("Blad1"), CStr(Trim(Range("E2").Value))

    Application.ScreenUpdating = True

End Sub

Robert Smidt zei:
Wat ik nog wel graag zou weten of het mogelijk is de data vanuit ander bestand ingelezen kan worden vanuit voornoemde sjabloon

Kijk in dit bestandje voor mogelijkheid tot kopieeren van bladen van alle geopende bestanden
Bekijk bijlage TestCopy.xls

Robert Smidt · 21 jan 2011

volgens mij heb ik de vraag verkeerd geformuleerd

Hoi Mark,

het is niet de bedoeling dat D2 --> E2 moet zijn, maar dat in d2 het e-mailadres komt te staan en dat in E3 de naam (incl. het volgnummer) die de macro er aan heeft gegeven. Dat is nl. van belang omdat dit bestand in een latere fase verwijderd moet worden vanuit het systeem, dan zal het systeem moeten weten onder welke naam het bestand is opgeslagen.

Ik hoop dat het je lukt, volgens mij is dit geen eenvoudige opgave en nogmaals mijn verontschuldiging dat ik de vraag niet duidelijk heb geformuleerd.

Alvast wederom bedankt.

Robert Smidt · 23 jan 2011

Helaas nog geen antwoord, ik hoop dat de vraag niet te moeilijk is.

Hoi Mark,

het is het niet de bedoeling dat D2 --> E2 moet zijn, maar dat in d2 het e-mailadres komt te staan en dat in E3 de naam (incl. het volgnummer) die de macro er aan heeft gegeven. Dat is nl. van belang omdat dit bestand in een latere fase verwijderd moet worden vanuit het systeem, dan zal het systeem moeten weten onder welke naam het bestand is opgeslagen.

Ik hoop dat het je lukt, volgens mij is dit geen eenvoudige opgave en nogmaals mijn verontschuldiging dat ik de vraag niet duidelijk heb geformuleerd.

Alvast wederom bedankt.

Warme bakkertje · 23 jan 2011

Robert, we plaatsen er nog een functie bij

Code:

Function ExtractFileName(filespec) As String
    Dim x As Variant
    x = Split(filespec, Application.PathSeparator)
    ExtractFileName = x(UBound(x))
End Function

en vullen deze Sub dan aan met een regeltje

Code:

Private Sub SaveToFile(ByRef Mysheet As Worksheet, _
                        ByVal sFile As String)

    If sFile <> "" Then

        sFile = NewFileName(sFile)
     [COLOR="red"]   [E2] = ExtractFileName(sFile)[/COLOR]
        Mysheet.Copy
        
        With ActiveWorkbook
        
            .SaveAs sFile & ".xls"
            .Close
            
        End With
        
    End If
    
End Sub

Robert Smidt · 23 jan 2011

Helemaal super

Warme Bakkertje,

De code werkt perfect, ik zal dat morgen gelijk op het werk uitproberen (excel 97).

Nogmaals bedankt voor de oplossing.

Robert Smidt · 24 jan 2011

Helaas te vroeg gejuicht!

Helaas, werkt onderstaande code niet bij Excel '97 is hier een alternatief voor?

Sub of function is niet gedefineerd

Function ExtractFileName(filespec) As String Dim x As Variant
x = Split(filespec, Application.PathSeparator)
ExtractFileName = x(UBound(x))
End Function

Alvast bedankt,

Groeten, Robert

Warme bakkertje · 25 jan 2011

Code:

Function ExtractFileName(filespec) As String
'werkt met XL97
    Dim x As Variant
    x = Evaluate("{""" & Application.Substitute(filespec, _
"\", """,""") & """}")
    ExtractFileName = x(UBound(x))
End Function

Mark xl · 25 jan 2011

Beste Robert,

Ik heb effe de constante met de mapnaam modulebreed neergezet, en met een simpele replace heb je dan de bestandsnaam in cel E2.

Wel lastig om code te testen als je zelf geen Excel 97 hebt, ..zoals ik.
Gelukkig zijn daar dan de oude rotten in het vak die daar weer alles vanaf weten en je beter verder kunnen helpen.

hopelijk werkt het nu goed.

Code:

Option Explicit

Private Const spath As String = _
    "C:\Documents and Settings\smidr00\Bureaublad\Bos\Gereed voor verrijking\"
Sub OpslaanAls()

    Application.ScreenUpdating = False

    If Range("D2") = "" Then
    
        Range("D2") = InputBox("Helaas staat " & _
            "het e-mailadres van de GDW niet in het " & _
            "bestand; vul deze alsnog handmatig in!")
    
    End If
    
    SaveToFile Sheets("Blad1"), CStr(Trim(Range("D2").Value))

    Application.ScreenUpdating = True

End Sub

Private Sub SaveToFile(ByRef Mysheet As Worksheet, _
                        ByVal sFile As String)

    If sFile <> "" Then

        sFile = NewFileName(sFile)
        
        With Mysheet
        
            .Range("E2") = Replace(sFile, spath, "")
            .Copy
        
        End With
        
        With ActiveWorkbook
                
            .SaveAs sFile
            .Close
            
        End With
        
    End If
    
End Sub

Private Function NewFileName(ByVal sName As String) As String

Dim lIndex As Long
    
    sName = spath & sName & "   "
    
    Do While Dir(Trim(sName) & ".xls") <> ""
    
        lIndex = lIndex + 1
        sName = Mid(sName, 1, Len(sName) - 3) & " " & _
                    Right("00" & CStr(lIndex), 2)
    
    Loop

    sName = sName & ".xls"
    NewFileName = Trim(sName)

End Function

Robert Smidt · 26 jan 2011

Helaas

Bedankt voor de moeite die je voor mij hebt gedaan, echter krijg ik een foutmelding "Sub of Function is niet gedefineerd". De foutmelding staat bij regel:

.Range("E2") = Replace(sFile, spath, "")
Het woord "Replace" wordt geaccentueerd. Verder heb ik gekeken of ik geen fout in de tekst heb maar dat is ook niet het geval. Verder werkt de code wel, hij maakt netjes een nieuw bestand aan met een nieuw volgnummer.

Hopelijk heb je een oplossing.

Alvast bedankt.

Opslaan als (waarde v.e. cel), indien naam aanwezig hier een volgnummer aan toevoegen

Gebruiker

Inventaris

Gebruiker

Meubilair

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Gebruiker

Meubilair

Gebruiker

Gebruiker

Meubilair

Gebruiker

Gebruiker

Wij waarderen jouw privacy