Question

尝试将当前的Excel工作表另存为PDF时，我的一些VBA代码出现了奇怪的行为。

以下代码在具有Excel 365 ProPlus版本1803（内部版本9126.2336）的Windows 7计算机上可以很好地工作，但是在另一台具有Excel 365版本1901（内部版本11231.20174）的Windows 7计算机上遇到错误1004。 >

任何建议，是什么原因可能导致错误？

编辑（晚上10:04）：

我尝试在两台不同计算机上的完全相同的文件夹中使用完全相同的文件，唯一的区别似乎是Excel的版本。在“较旧的” Excel 365构建中，一切正常，而在较新的Excel 365构建中，我遇到了错误。

该错误发生在最后一个名为“ PDFActiveSheet”的子代码的以下代码行上：

wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=fsFileName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

在测试机上，当我遇到错误时，字符串fsFileName具有以下值：

fsFileName : "C:\Users\Julchen\Downloads\Test\testfile.pdf" : String

想法是，用户选择一个文件夹（内部有一个或多个.tsv文件），然后宏打开并更改这些tsv文件中的每一个，以使其成为支持Amazon FBA的EAN列表，然后将所有内容另存为PDF。这是我的完整代码：

Option Explicit

Sub Pick_Folder()
    Dim fs As Object
    Dim fsFileName As Variant
    Dim fsDir As Object
    Dim sItem, s As String
    Dim fldr As FileDialog
    Dim Counter As Integer

'Let user choose the folder where the TSV files are stored
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Wählen Sie einen Ordner..."
    .AllowMultiSelect = False
    .InitialFileName = Application.DefaultFilePath
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With

'Check if subfolder "Output" exists in chosen folder, if not then create it.
Set fs = CreateObject("Scripting.FileSystemObject")
Set fsDir = fs.getfolder(sItem)
If Not fs.FolderExists(sItem & "\Output") Then
    MkDir sItem & "\Output"
End If

'Cycle through all files in the chosen folder and open the alter macro to create EAN codes, then save the file as PDF and count how many files were processed.
Application.ScreenUpdating = False
Counter = 0
For Each fsFileName In fsDir.Files
    s = fsFileName
    Call Create_EAN_files(s)
    Call PDFActiveSheet(s)
    Application.DisplayAlerts = False
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Counter = Counter + 1
Next

Application.ScreenUpdating = True
MsgBox ("Finished! The macro created " & Counter & " PDF files in the following folder: " & Left(s, InStrRev(s, "\")))
Exit Sub
NextCode:
    Set fldr = Nothing
End Sub

Sub Create_EAN_files(fsFileName$)
Dim Entry As Integer
Dim EANText As String

    Workbooks.OpenText Filename:= _
        fsFileName, Origin:=65001, StartRow _
        :=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
        ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
        , Space:=False, Other:=False, FieldInfo:=Array(Array(1, 1), Array(2, 1)), _
        TrailingMinusNumbers:=True
    ActiveWindow.Zoom = 70
    Columns(1).ColumnWidth = 31.57
    Columns(2).ColumnWidth = 115
    ActiveWorkbook.ActiveSheet.Columns("C:D").Delete
    Columns(3).ColumnWidth = 22.71
    ActiveWorkbook.ActiveSheet.Columns("D:G").Delete
    Range("D1").EntireColumn.Insert
    Columns(4).ColumnWidth = 28
    Columns(5).ColumnWidth = 22

    For Entry = ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).End(xlUp).Row + 1 To ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row
 ' Variables needed (remember to use "option explicit").   '
    Dim retval, s As String    ' This is the return string.      '
    Dim i As Integer        ' Counter for character position. '

    ' Initialise return string to empty                       '
    s = ActiveWorkbook.ActiveSheet.Cells(Entry, 3).Value
    retval = ""

    ' For every character in input string, copy digits to     '
    '   return string.                                        '
    For i = 1 To Len(s)
        If Mid(s, i, 1) >= "0" And Mid(s, i, 1) <= "9" Then
            retval = retval + Mid(s, i, 1)
        End If
    Next
    ' Then return the return string.                          '
    ActiveWorkbook.ActiveSheet.Cells(Entry, 3).Value = retval
    ActiveWorkbook.ActiveSheet.Cells(Entry, 3).NumberFormat = "0"
    EANText = ActiveWorkbook.ActiveSheet.Cells(Entry, 3).Value
    EANText = ean13N(EANText)
    ActiveWorkbook.ActiveSheet.Cells(Entry, 4).Value = EANText
    With ActiveWorkbook.ActiveSheet.Cells(Entry, 4).Font
        .Name = "Code EAN13"
        .Size = 50
    End With
    Next Entry

Columns(2).HorizontalAlignment = xlLeft
Columns(2).WrapText = True
Columns(3).HorizontalAlignment = xlCenter
Columns(5).HorizontalAlignment = xlCenter

Range(Cells(ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).End(xlUp).Row, 1).Address, Cells(ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row, 5).Address).Select

    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.VerticalAlignment = xlCenter

ActiveSheet.PageSetup.RightHeader = "Picken:      [    ]" & Chr(10) & _
"Buchung:  [    ] " & Chr(10) & _
"EAN Etiketten Drucken : [    ]" & Chr(10) & _
"Kontrolle:  [    ]" & Chr(10) & _
"SC Etiketten Druck : [    ]" & Chr(10) & _
"SC als Versendet Markieren : [    ]" & Chr(10) & _
"End-Kontrolle : [    ]"

ActiveSheet.PageSetup.LeftFooter = "OA / Amazon FBA"
ActiveSheet.PageSetup.RightFooter = Date & " / " & Time()
ActiveSheet.PageSetup.Orientation = xlLandscape
ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1).Address, Cells(ActiveWorkbook.ActiveSheet.Cells(Rows.Count, 3).End(xlUp).Row, 5).Address).Address

Application.PrintCommunication = False
    ActiveSheet.PageSetup.FitToPagesWide = 1
    ActiveSheet.PageSetup.FitToPagesTall = False
Application.PrintCommunication = True

End Sub

Public Function ean13N(chaine)
    Dim i%, checksum%, first%, CodeBarre$, tableA As Boolean
    ean13N = ""

'   checking that all characters in the barcode are digits
    For i% = 1 To Len(chaine)
        If Asc(Mid$(chaine, i%, 1)) < 48 Or Asc(Mid$(chaine, i%, 1)) > 57 Then
            ean13N = ""
            Exit Function
        End If
    Next

'   Calculating the check digit
    If Len(chaine) = 12 Then
        For i% = 2 To 12 Step 2
            checksum% = checksum% + Val(Mid$(chaine, i%, 1))
        Next
        checksum% = checksum% * 3
        For i% = 1 To 11 Step 2
            checksum% = checksum% + Val(Mid$(chaine, i%, 1))
        Next
        chaine = chaine & (10 - checksum% Mod 10) Mod 10
    End If

'   developing the barcode string
    If Len(chaine) = 13 Then
    '   The first number is taken as is, the second is from Table A
        CodeBarre$ = Left$(chaine, 1) & Chr$(65 + Val(Mid$(chaine, 2, 1)))
        first% = Val(Left$(chaine, 1))
        For i% = 3 To 7
            tableA = False
            Select Case i%
                Case 3
                    Select Case first%
                Case 0 To 3
                    tableA = True
                End Select
            Case 4
                Select Case first%
                Case 0, 4, 7, 8
                    tableA = True
                End Select
            Case 5
                Select Case first%
                Case 0, 1, 4, 5, 9
                tableA = True
                End Select
            Case 6
                Select Case first%
                Case 0, 2, 5, 6, 7
                tableA = True
                End Select
            Case 7
                Select Case first%
                Case 0, 3, 6, 8, 9
                tableA = True
                End Select
            End Select

            If tableA Then
                CodeBarre$ = CodeBarre$ & Chr$(65 + Val(Mid$(chaine, i%, 1)))
            Else
                CodeBarre$ = CodeBarre$ & Chr$(75 + Val(Mid$(chaine, i%, 1)))
            End If
        Next

        CodeBarre$ = CodeBarre$ & "*"   'Adding central divider
        For i% = 8 To 13
            CodeBarre$ = CodeBarre$ & Chr$(97 + Val(Mid$(chaine, i%, 1)))
        Next
        CodeBarre$ = CodeBarre$ & "+"   'adding the terminating char
        ean13N = CodeBarre$
    End If
End Function

Sub PDFActiveSheet(fsFileName$)
Dim wsA As Worksheet
Dim wbA As Workbook

On Error GoTo errHandler

1  Set wbA = ActiveWorkbook
2  Set wsA = ActiveSheet

'create default name for savng file
3  fsFileName = Replace(fsFileName, ".tsv", ".pdf")
4  fsFileName = Left(fsFileName, InStrRev(fsFileName, "\")) & "Output\" & Right(fsFileName, Len(fsFileName) - InStrRev(fsFileName, "\"))

5  wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=fsFileName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file. Error on Line : " & Erl
    Resume exitHandler
End Sub

Answer 1

问题可能是输出文件夹不存在。试试这个：

Sub PDFActiveSheet()

Dim wsA As Worksheet
Dim wbA As Workbook
Dim fsFileName, fsFolder As String
On Error GoTo errHandler

Set wbA = ActiveWorkbook
Set wsA = ActiveSheet

fsFolder = "C:\Users\testuser\Downloads\Test\"
fsFileName = "testfile.tsv"

'create default name for saving file
fsFolder = Left(fsFolder, InStrRev(fsFolder, "\")) & "Output\" & Right(fsFolder, Len(fsFolder) - InStrRev(fsFolder, "\"))

' create folder if it doesn't exist
If Len(Dir(fsFolder, vbDirectory)) = 0 Then
    CreateDir fsFolder
End If

fsFileName = fsFolder & Replace(fsFileName, ".tsv", ".pdf")

wsA.ExportAsFixedFormat _
        Type:=xlTypePDF, _
        Filename:=fsFileName, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create PDF file."
    Resume exitHandler
End Sub

Sub CreateDir(strPath As String)
    Dim elm As Variant
    Dim strCheckPath As String

    strCheckPath = ""
    For Each elm In Split(strPath, "\")
        strCheckPath = strCheckPath & elm & "\"
        If Len(Dir(strCheckPath, vbDirectory)) = 0 Then MkDir strCheckPath
    Next
End Sub

SaveAs PDF宏在不同的Excel版本上的行为异常

1 个答案: