Avatar billede Morten S. Juniormester
06. februar 2017 - 14:22 Der er 4 kommentarer

Gem flere worddokumenter som pdf med celleværdi som navn

Hej.
Jeg har prøvet at lave en kode som åbner et word dokument, kopiere et område fra et excel ark, sætter ind og gemmer som pdf, med navn som værdien i celle ("y18"), og derefter går videre til næste excel ark og gør præcis det samme, dog gemmer med et nyt navn. Det går fint med at få de over i word, men den gemmer ikke. Nogen der kan hjælpe? :) Her er min kode:

Sub toWord()
Dim ws As Worksheet
Dim Wkbk1 As Workbook
Dim wdapp As Object
Dim wddoc As Object
Dim orng As Object
Dim strdocname As String
Dim navn As Range
Dim filnavn As String


Set navn = ActiveSheet.Range("y18")

    For Each ws In ActiveWorkbook.Worksheets
   
   
    Set Wkbk1 = ActiveWorkbook
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    strdocname = "C:\Users\Morten\Documents\Arbejde\prøve med kode\royalty skabalon.docx"
   
    filnavn = navn.Value
   
   

    'file name & folder path
    On Error Resume Next
    'error number 429
    Set wdapp = GetObject(, "Word.Application")
    If Err.Number = 429 Then
        Err.Clear
        'create new instance of word application
        Set wdapp = CreateObject("Word.Application")
    End If
    wdapp.Visible = True
    'define paths to file
    If Dir(strdocname) = "" Then
        'MsgBox "The file" & strdocname & vbCrLf & "was not found " & vbCrLf & "C:\Path\Name.doc", _
        '      vbExclamation, "The document does not exist "
        'Exit Sub
        Set wddoc = wdapp.Documents.Add
    Else
        Set wddoc = wdapp.Documents.Open(strdocname)
    End If
If ws.Name <> "hovedark" Then
        ws.Range("x13:AA44").Copy
        Set orng = wddoc.Range
        orng.Paste
        orng.End = wddoc.Range.End
    End If
    wddoc.ExportAsFixedFormat OutputFileName:="C:\Users\Morten\Documents\Arbejde\prøve med kode\" & filnavn, ExportFormat:=wdExportFormatPDF

    oWord.Quit
    Set oWord = Nothing
    Next ws

lbl_Exit:
    Set orng = Nothing
    Set wddoc = Nothing
    Set wdapp = Nothing
    Set Wkbk1 = Nothing
    Set ws = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Exit Sub
End Sub
Avatar billede supertekst Ekspert
06. februar 2017 - 16:51 #1
Hej

set Navn ligger uden for din Løkke
Avatar billede Morten S. Juniormester
06. februar 2017 - 17:45 #2
Hej supertekst.

Selvom jeg sætter set Navn indenfor løkken, virker det stadig ikke.
Avatar billede supertekst Ekspert
06. februar 2017 - 17:58 #3
Vender tilbage senere
Avatar billede supertekst Ekspert
07. februar 2017 - 22:52 #4
Hvis du vil have mine testfiler - så: www.supertekst-it.dk | Kontakt
- så vil jeg svare (bliver nok først i morgen eftermiddag/aften) - så kan jeg sende filerne

Her er første version


Rem I værktøjslinjen VBA: Tools / References / Microsoft Word er markeret
Rem version 1 -
Rem ============================================================
Const systemFilNavn = "System.xlsm"
Dim systemSti As String
Dim system As Workbook
Dim antalArk As Integer

Dim wDoc As Object
Const skabelonNavn = "Skabelon.docx"
Private Sub Workbook_Open()
    houseKeeping
End Sub
Private Sub houseKeeping()
Dim ark As Integer
    Set system = ActiveWorkbook
    system.Sheets(1).Activate
   
On Error GoTo fejl_Afslut
   
    systemSti = ActiveWorkbook.Path
    antalArk = ActiveWorkbook.Sheets.Count
   
Rem åbn Word skabelon
    Set wDoc = CreateObject("Word.Application")
    wDoc.documents.Open systemSti & "\" & skabelonNavn

Rem Traverser Ark
    For ark = 1 To system.Sheets.Count
        system.Sheets(ark).Activate
        If ActiveSheet.Name <> "Hovedark" Then
Rem Gem Dokument som pdf
            filnavn = system.ActiveSheet.Range("Y18")
            wDoc.ActiveDocument.ExportAsFixedFormat OutputFileName:="D:\" & filnavn & ".pdf", ExportFormat:=wdExportFormatPDF
        End If
    Next ark
   
fejl_Afslut:
    On Error Resume Next
   
    wDoc.Quit
    Set wDoc = Nothing
   
    MsgBox "Slut"
End Sub
Avatar billede Ny bruger Nybegynder

Din løsning...

Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.

Loading billede Opret Preview

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester