Åben flere filer i samme bibliotek og gem som PDF - VBA

Her er noget kode som jeg ofte benytter mig af. Det er kopi er alt kode i et kodemodul, hvis og du kan teste det ved at køre makroen "DebugPrintFilesNames" og se resultatet i Immediate (Ctrl+G) vinduet.

Inde i løkken
    For iZ = 1 To miX
        Debug.Print mstrFileNames(iZ)
    Next iZ
kan du sikkert udskrifte Debug kommandoen med et eller andet der kalder din SaveAsPDF funktion.


Koden kan ses her:
http://www.smartoffice.dk/Tips/LibrarySource.asp?App=Shared&Lib=ReadFilesInDirectory

Jeg har forsøgt mig. Lidt uden held fordi den ikke vælger det bibliotek, som jeg har angivet. Men det kan være mig der ikke har overblikket. P.t. gemmer den den åbne fil som pdf i rigtigt bibliotek - men tager ikke de filer som er i biblioteket. Er nok ikke en stor ørn til dette.

Derudover: Hvorledes vælger brugeren lettest biblioteket (hvor xls-filerne ligger) - via en userform (kan man jo lave) eller en dialogboks (men er det lettere med en eller anden form for dialogboks). Det kan jeg ikke umiddelbart gennemskue.

Koden - som i øvrigt er kopi jf ovenfor:

Option Explicit
Private mstrFileNames() As String
Private miX As String
Public PDFNavn, PDFFilnavn As String
Public Sub DebugPrintFilesNames()
Dim iZ As Integer

FindTheFiles "C:\TestMakro\FilBibliotek", "xls"

For iZ = 1 To miX
   
'navngivning og gem af pdf-fil.
    Range("A1").Select
    ActiveCell.FormulaR1C1 = _
        "=MID(CELL(""filnavn""),FIND(""["",CELL(""filnavn""))+1,FIND("".xls"",CELL(""filnavn""))-FIND(""["",CELL(""filnavn""))-1)"
    PDFNavn = ActiveCell.Value
   
    PDFFilnavn = "C:\TestMakro\FilBibliotek\PDFTest\" & PDFNavn & ".pdf"

    Sheets(1).Select
   
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFilnavn, Quality _
        :=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
   
Next iZ

End Sub
Public Sub FindTheFiles(ByVal strFilePath As String, ByVal strFileType As String)
    Dim strTmpFileName As String

    'Vælger bibliotek
    If Not Right(strFilePath, 1) = "\" Then strFilePath = strFilePath & "\"
    miX = 0
       
    'Indlæsning af filer til et array
    miX = 0
    ReDim Preserve mstrFileNames(miX)
    strTmpFileName = Dir(strFilePath)
    mstrFileNames(miX) = strTmpFileName
   
    Do
        strTmpFileName = Dir
        If strTmpFileName <> "" Then
            If LCase(Right(strTmpFileName, Len(strFileType))) = LCase(strFileType) Then
                miX = miX + 1
                ReDim Preserve mstrFileNames(miX)
                mstrFileNames(miX) = strTmpFileName
            End If
        Else
            Exit Do
        End If
    Loop

    'Sortering af filnavne alfabetisk (kun i Word)
    'WordBasic.SortArray mstrFileNames()
End Sub

Du åbner slet ikke noget regneark på noget tidspunkt... måske denne her vil hjælpe dig på vej

Option Explicit

Private Const mstrFilePath As String = "d:\VBA\_Test\" 'Skal slutte med en \
Private mstrFileNames() As String
Private miX As String
Public PDFNavn, PDFFilnavn As String

Public Sub DebugPrintFilesNames()
    Dim iZ As Integer
    Dim wbTemp As Workbook
    Dim sUserPath As String
   
    sUserPath = UserSelectFilePath
    FindTheFiles sUserPath, "xls"
   
    For iZ = 1 To miX
   
        'Åben fil
        Set wbTemp = Application.Workbooks.Open(sUserPath & mstrFileNames(iZ))
               
        '*** kode jeg ikke har pillet i ***
        '***********************************
        'navngivning og gem af pdf-fil.
        Range("A1").Select
        ActiveCell.FormulaR1C1 = _
            "=MID(CELL(""filnavn""),FIND(""["",CELL(""filnavn""))+1,FIND("".xls"",CELL(""filnavn""))-FIND(""["",CELL(""filnavn""))-1)"
        PDFNavn = ActiveCell.Value
       
        PDFFilnavn = sUserPath & "PDFTest\" & PDFNavn & ".pdf"
   
        Sheets(1).Select
       
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=PDFFilnavn, Quality _
            :=xlQualityMinimum, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            OpenAfterPublish:=False
        '***********************************
       
        ' Luk fil
        wbTemp.Close SaveChanges:=False
        Set wbTemp = Nothing
    Next iZ

End Sub

Public Function UserSelectFilePath() As String
    Dim sRetVal
    Dim vntFileToOpen As Variant
    Dim iChar As Integer
   
    vntFileToOpen = Application.GetOpenFilename("Text Files (*.xls), *.xls")
    If vntFileToOpen <> False Then
        'MsgBox "Open " & vntFileToOpen
        For iChar = Len(vntFileToOpen) To 1 Step -1
            If Mid(CStr(vntFileToOpen), iChar, 1) = "\" Then
                sRetVal = Left(CStr(vntFileToOpen), iChar)
                Exit For
            End If
        Next iChar
    End If
   
    UserSelectFilePath = sRetVal
End Function

Public Sub FindTheFiles(ByVal strFilePath As String, ByVal strFileType As String)
    Dim strTmpFileName As String

    'Vælger bibliotek
    If Not Right(strFilePath, 1) = "\" Then strFilePath = strFilePath & "\"
    miX = 0
       
    'Indlæsning af filer til et array
    miX = 0
    ReDim Preserve mstrFileNames(miX)
    strTmpFileName = Dir(strFilePath)
    mstrFileNames(miX) = strTmpFileName
   
    Do
        strTmpFileName = Dir
        If strTmpFileName <> "" Then
            If LCase(Right(strTmpFileName, Len(strFileType))) = LCase(strFileType) Then
                miX = miX + 1
                ReDim Preserve mstrFileNames(miX)
                mstrFileNames(miX) = strTmpFileName
            End If
        Else
            Exit Do
        End If
    Loop

    'Sortering af filnavne alfabetisk (kun i Word)
    'WordBasic.SortArray mstrFileNames()
End Sub

Tusind tak.
Kan selvfølgelig godt se, at der manglede et "/".

Mht sidste kode kan jeg ikke helt gennemskue:
Private Const mstrFilePath As String = "d:\VBA\_Test\". Hvorfor dette bibliotek?

Men koden gør, at jeg kan vælge en fil i et bibliotek. Dette gør jeg så. Vælger den første fil (ud af 2 xls-filer) i det ønskede bibliotek. Men den laver kun en pdf af den sidste fil - (eller overskriver denne). Såvidt jeg kan se.

Private Const mstrFilePath As String = "d:\VBA\_Test\". Hvorfor dette bibliotek?
- bliver faktisk slet ikke brugt - den blever overflødig igen - bare slet det

To rettelser

Private miX As String - skal være - Private miX As Integer
For iZ = 1 To miX - skal være - For iZ = 0 To miX

Hvordan der bliver gemt PDF filer, og hvordan du navngiver dem, det har jeg ikke pillet i, det må du selv lege lidt med eller kontakte mig via mine kontaktoplysninger på min brugerprofil.

Det fungere fint. Tusind tak.

Det er meget fint, at man ikke skal lave en userform, men istedet bruge den almindelige åbn-dialogboks. Man vælger blot den første fil - og så kører det bare. (ihvertfald i den test jeg har lavet).

En FreeWare version som Excel 2007 Add-In kan hentes her http://www.smartoffice.dk/Tips/FreeWare/Index.asp

Igang med en større test. Støt ind i at Excel-filer jo ikke mere er én type ifm 2007 er lanceret. Hvordan angiver jeg, at den skal finde andre typer end blot '.xls'

Se def:
FindTheFiles sUserPath, "xls"