VBA:PDF转置

VBA记录一下遇到的转置后占用问题:（1）

Sub Xuanwj()
    Dim path$, filename$, fn$
    Dim arr(1 To 999, 1 To 9)
    Dim arr1(1 To 999, 1 To 6)
    Dim a1%, a2%, a3%, s1%, s2%, s3%, Tableno%, Rows%
    Dim t As Date
    Application.ScreenUpdating = False    '屏幕闪烁关闭
    Application.DisplayAlerts = False
   With Application.FileDialog(msoFileDialogFolderPicker)
    If .Show = -1 Then
    'filedialog对象的show方法显示对话框,并且返回 -1(如果你按OK) 和 0 (如果你按CANCEL)
        path = .SelectedItems(1)
        'MsgBox "你选择的文件夹是: " & .SelectedItems(1), vbOKOnly + vbInformation, "标题"
    Else
        'MsgBox "未选择"
        Exit Sub
    End If
    End With
    t = Timer
 filename = Dir(path & "\*.pdf")    '对文件夹内的工作簿进行循环，循环查找的格式  *.pdf
    ' MsgBox filename
    a1 = 1
    Do While filename <> ""
        '对文件夹内的工作簿进行循环，截止到最后一个工作簿
            fn = path & "\" & filename    '取得循环符合条件工作簿的  文件夹地址，赋值给fn 这个变量
            ' MsgBox "现在汇总的工作簿是fn= " & fn
            Set wordapp = CreateObject("Word.Application")
            Set WordDoc = wordapp.Documents.Open(filename:=fn, ReadOnly:=True)
             wordapp.Visible = False
             '调用Wordapp打开PDF格式
            Set WDDOC = GetObject(fn)
        With WDDOC
                Tableno = .Tables.Count    '文件的页数
            On Error Resume Next
                '复制文档中表格部分文本
            For s1 = 1 To Tableno
                For s2 = 1 To .Tables(s1).Range.Rows.Count
                    For s3 = 1 To .Tables(s1).Range.Columns.Count
                            arr(a1 + s2, 1 + s3) = Replace(Replace(Replace(.Tables(s1).Cell(s2, s3).Range.Text, "", ""), Chr(13), ""), "End Of PO", "")
                            arr(a1 + s2, 1) = Replace(Right(filename, 13), ".pdf", "")
                    Next
                Next
                    a1 = a1 + s2
            Next
            'Debug.Print arr(44, 1) & "/" & arr(44, 2) & "/" & arr(44, 3) & "/" & arr(44, 4) & "/" & arr(44, 6) & "/" & arr(44, 7) & "/" & arr(44, 8)
        End With
        Set WDDOC = Nothing
        WDDOC.Close False
        WDDOC.Application.Quit '关闭
        wordapp.Quit
        
        filename = Dir      '进行下一步的循环
        Loop
            Rows = 1
            For a2 = 1 To a1
                    If (arr(a2, 2) > 0) And (arr(a2, 2) < 999) Then
                    arr1(Rows, 1) = arr(a2, 1)
                    arr1(Rows, 2) = arr(a2, 3)
                    arr1(Rows, 3) = arr(a2, 4)
                    arr1(Rows, 4) = arr(a2, 5)
                    arr1(Rows, 5) = arr(a2, 6)
                    arr1(Rows, 6) = arr(a2, 7)
                    Rows = Rows + 1
                    End If
            Next
        ThisWorkbook.Worksheets(1).Cells.Clean
        ThisWorkbook.Worksheets(1).Range("a1:f1") = Array("订单号", "SKU", "品名", "店名", "订货量", "单价")
        ThisWorkbook.Worksheets(1).Range("a2").Resize(UBound(arr1, 1), UBound(arr1, 2)) = arr1
        ThisWorkbook.Worksheets(1).Cells.EntireColumn.AutoFit
        Application.ScreenUpdating = True    '屏幕闪烁打开
        Application.DisplayAlerts = True
        MsgBox "转换完成,用时:" & Format(Timer - t, "###")

END SUB

1.Set wordapp = CreateObject("Word.Application")之后调用WORK(桌面)打面指定文件夹内PDF后会生成一个桌面WORK，后续不加wordapp.Quit会一直占用着（导至转置后的PDF改不了名子等操作)
2.初次把PDF调用桌面WORK格式打开时会显示对话框。如不确认并勾选不再显示程序会进入假死。
3.Replace(Replace(Replace(.Tables(s1).Cell(s2, s3).Range.Text, "", ""), Chr(13), ""), "End Of PO", "")部分PDF转WORK会生成不知名的各种乱码如""