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

met onderstaande VBA worden perfect 2x pdf gemaakt

  • Onderwerp starter Onderwerp starter Ropw
  • Startdatum Startdatum
Status
Niet open voor verdere reacties.
R

Ropw

Gebruiker
Lid geworden
12 apr 2017
Berichten
192
Met onderstaande VBA worden perfect 2x pdf gemaakt en opgeslagen, maar zou graag ook het excel bestand met dezelfde naam en locatie willen opslaan.
Ben al een tijdje wezen stoeien om zelfde regels toe te voegen met xlms, maar krijg het niet voor elkaar. graag hulp

Sub Opsl_PDF()
pdf = "c:\facturen" & Sheets("Factuur").Range("h24") & Range("r1") & Range("q1") & " " & Range("c15") & ".pdf"
If Dir(pdf) <> "" Then
If MsgBox("Een PDF met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "PDF bestaat al") = vbNo Then
Exit Sub
End If
End If
Sheets("factuur").ExportAsFixedFormat 0, pdf, , , , , , False

pdf = "c:\facturen" & Sheets("uren").Range("k2") & Range("r1") & Range("q1") & " " & Range("c15") & " UREN" & ".pdf"
If Dir(pdf) <> "" Then
If MsgBox("Een PDF met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "PDF bestaat al") = vbNo Then
Exit Sub
End If
End If
Sheets("uren").ExportAsFixedFormat 0, pdf, , , , , , False
End Sub
 
Wat dacht je van een voorbeeldje? En nog een idee: zet je code ook in CODE tags, leest wel zo prettig.
 
Deze code is blijkbaar niet door jou gemaakt.
Ik sluit me bij de suggesties van @Octa aan.
Gebruik de macrorecorder en je vraag wordt in situ beantwoord.
 
Bedankt voor de reactie. Vergeef me, ik ben er al een tijdtje tussenuit.
Hoop dat het nu wel duidelijk is. Met de VBA in het voorbeeldbestand worden perfect 2x pdf gemaakt en opgeslagen, maar ik zou graag ook het bijbehorende excel bestand met dezelfde naam als de pdf's willen opslaan.
Zelf ook met de macrorecorder aan de gang geweest, maar zonder gewenst resultaat.
de namen in PDF komen er zo uit te zien 2023000 - AP - selecteer tekst wat toegevoegd wordt aan de PDF bestandsnaam ---.pdf
Dus de naam van het excel bestand moet in dit geval dan worden 2023000 - AP - selecteer tekst wat toegevoegd wordt aan de PDF bestandsnaam ---.xlms
 

Bijlagen

Maak er eens dit van:
Code: 
Sub Opsl_PDF()
    pdf = "c:\ANKERfacturen\" & Sheets("Factuur").Range("h24") & Range("r1") & Range("q1") & " " & Range("c15") & ".pdf"
    If Dir(pdf) <> "" Then
        If MsgBox("Een PDF met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "PDF bestaat al") = vbNo Then
            Exit Sub
        End If
    End If
    Sheets("factuur").ExportAsFixedFormat 0, pdf, , , , , , False
        
    exc = Replace(pdf, ".pdf", ".xlsm")
    If Dir(exc) <> "" Then
        If MsgBox("Een document met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "Document bestaat al") = vbYes Then
            ThisWorkbook.SaveCopyAs exc
        End If
    End If
End Sub
 
Laatst bewerkt:
Moet dit
Dus de naam van het excel bestand moet in dit geval dan worden 2023000 - AP - selecteer tekst wat toegevoegd wordt aan de PDF bestandsnaam ---.xlms
Klik om te vergroten...
niet worden
Dus de naam van het excel bestand moet in dit geval dan worden 2023000 - AP - selecteer tekst wat toegevoegd wordt aan de PDF bestandsnaam ---.xlsm
Klik om te vergroten...
 
sorry tikfoutje de extensie moet uiteraard zijn xlsm

Maar het resultaat moet 3 bestanden opleveren
-1 excel
-2 pdf bestandjes (eentje krijgt nog de toevoeging UREN
 
Met wat er in #5 staat zou je dat nu zelf moeten kunnen doen.
 
het kwartje valt nog niet bij me. Het resultaat met #5 is dat ik daarmee nu slechts één pdf bestandje krijg. Ongetwijfeld moet ik daarmee aan de slag. Ik ga ermee stoeien. Bedankt toch voor het meedenken.
 
De code in #5 maakt 1 PDF en 1 Excel document.
Dan lijkt het me toch duidelijk wat je moet doen om die 2e PDF te maken.
 
Voel me behoorlijk dom, maar ik ben er bijna, hoop ik. Maar met #5 wordt er slechts 1 pdf gemaakt. De correctie naar 2 pdf heb ik in onderstaande VBA weer aangepast
Maar het excel bestand zelf krijg ik nog steeds niet!!! Het moet het hele excel bestand worden (dus alle sheets ofwel het workbook)

Sub Opsl_PDF()
pdf = "c:\ANKERfacturen" & Sheets("Factuur").Range("h24") & Range("r1") & Range("q1") & " " & Range("c15") & ".pdf"
If Dir(pdf) <> "" Then
If MsgBox("Een PDF met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "PDF bestaat al") = vbNo Then
Exit Sub
End If
End If
Sheets("factuur").ExportAsFixedFormat 0, pdf, , , , , , False



pdf = "c:\ANKERfacturen" & Sheets("uren").Range("k2") & Range("r1") & Range("q1") & " " & Range("c15") & " UREN" & ".pdf"
If Dir(pdf) <> "" Then
If MsgBox("Een PDF met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "PDF bestaat al") = vbNo Then
Exit Sub
End If
End If
Sheets("uren").ExportAsFixedFormat 0, pdf, , , , , , False


xlsm = "c:\ANKERfacturen" & Sheets("Factuur").Range("h24") & Range("r1") & Range("q1") & " " & Range("c15") & ".xlsm"
If Dir(xlsm) <> "" Then
If MsgBox("Een XLSM met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "XLSM bestaat al") = vbNo Then
Exit Sub
End If
End If
Sheets("factuur").ExportAsFixedFormat 0, xlsm, , , , , , False


exc = Replace(pdf, ".pdf", ".xlsm")
If Dir(exc) <> "" Then
If MsgBox("Een document met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "Document bestaat al") = vbYes Then
ThisWorkbook.SaveCopyAs exc
End If
End If

End Sub
 
Lees de laatste regel van #2 nog eens.
 
Zit er geen goede opticien in de buurt ?
 
geeft zeker een goed gevoel om dat te schrijven snb? Vooral zo doorgaan, lekker klantvriendelijk. Je waant je superieur.
toegevoegde waarde had m.i. de code niet omdat het voor mij niet beter leesbaarder is en omdat de VBA al in het voorbeeldbestand aanwezig was.\
verder meende ik echt iets simpels te vragen voor jullie geniale inzicht. De 2 PDF's gingen al perfect toen ik vroeg om het excel bestand zelf met eenzelfde naam in dezelfde diectory weg te schrijven.
Toen kreeg ik het terug, waarna nog maar een pdf werd gemaakt.Hoop energie voor een leek. evenzogoed een fijne avond
 
Sub SplitWorkbook()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook

DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "" & xWb.Name & " " & DateString

If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If

MkDir FolderName

For Each xWs In xWb.Worksheets
On Error GoTo NErro
If xWs.Visible = xlSheetVisible Then
xWs.Select
xWs.Copy
xFile = FolderName & "" & xWs.Name & FileExtStr
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
xNWb.SaveAs xFile, FileFormat:=FileFormatNum
xNWb.Close False, xFile
End If
NErro:
xWb.Activate
Next

MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub
 
Ropw,

Ik heb je ff geholpen om de code tussen CODE-tags te plaatsen.

Code: 
Sub SplitWorkbook()
'Updateby20200806
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook

DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "" & xWb.Name & " " & DateString

If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
Select Case xWb.FileFormat
Case 51:
FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If Application.ActiveWorkbook.HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56:
FileExtStr = ".xls": FileFormatNum = 56
Case Else:
FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If

MkDir FolderName

For Each xWs In xWb.Worksheets
On Error GoTo NErro
If xWs.Visible = xlSheetVisible Then
xWs.Select
xWs.Copy
xFile = FolderName & "" & xWs.Name & FileExtStr
Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
xNWb.SaveAs xFile, FileFormat:=FileFormatNum
xNWb.Close False, xFile
End If
NErro:
xWb.Activate
Next

MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub
 
Ropw zei:
toegevoegde waarde had m.i. de code niet omdat het voor mij niet beter leesbaarder is en omdat de VBA al in het voorbeeldbestand aanwezig was.
Klik om te vergroten...
Onzin argument; CODE tags gebruik je om de code LEESBAAR voor de lezers te maken, en niet voor jezelf. Dat de code ook al in het document zit, doet daar niets aan af: jouw berichtjes blijven daardoor gewoon onleesbaar. Dus niet zo eigenwijs doen, en gewoon de code tags gebruiken.
 
Octafish,

Kijk eens naar #16
 
#16, waar alle inspringpunten dus weg zijn.


@Ronpw:
Kijk eens naar dit, naar aanleiding van je vraag in #1:
Code: 
Sub Opsl_PDF()
    Doelmap = "C:\ANKERfacturen"
    
    [COLOR="#008000"]'-Controleer of de doelmap bestaat[/COLOR]
    If Dir("C:\ANKERfacturen", vbDirectory) = "" Then
        MkDir Doelmap
    End If

    pdf = "C:\ANKERfacturen\" & Sheets("Factuur").Range("H24") & Range("R1") & Range("Q1") & " " & Range("C15") & ".pdf"
    
    [COLOR="#008000"]'-Excel document[/COLOR]
    exc = Replace(pdf, ".pdf", ".xlsm")
    If Dir(exc) <> "" Then
        If MsgBox("Een document met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "Document bestaat al") = vbNo Then
            Exit Sub
        End If
    End If
    ThisWorkbook.SaveCopyAs exc

    [COLOR="#008000"]'-Eerste PDF[/COLOR]
    If Dir(pdf) <> "" Then
        If MsgBox("Een PDF met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "PDF bestaat al") = vbNo Then
            Exit Sub
        End If
    End If
    Sheets("factuur").ExportAsFixedFormat 0, pdf, , , , , , False
    
    [COLOR="#008000"]'-Tweede PDF[/COLOR]
    pdf = "C:\ANKERfacturen\" & Sheets("uren").Range("K2") & Range("K1") & Range("Q1") & " " & Range("C15") & " UREN" & ".pdf"
    If Dir(pdf) <> "" Then
        If MsgBox("Een PDF met dezelfde naam is al aanwezig." & vbCrLf & "Alsnog opslaan?", vbQuestion + vbYesNo, "PDF bestaat al") = vbNo Then
            Exit Sub
        End If
    End If
    Sheets("uren").ExportAsFixedFormat 0, pdf, , , , , , False
End Sub
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan