我有一个将工作簿中指定的表格保存到pdf文档的例行程序，但是如果我做了一些表格，我的例行程序就会失败

The list of sheets is specified in the names range "SaveList", which takes some as worksheets and some as charts (full page ones) but it falls over with

表的列表是在名称范围“SaveList”中指定的，它将一些作为工作表，一些作为图表(完整的页)，但是它会被删除。

run-time error 13 "type mismatch"

运行时错误13“类型不匹配”

Routine code below

下面程序代码

Sub SaveFile()
'Recalc Sheets prior to saving down

A = MsgBox("Do you want to Save the Performance Reports?", vbOKCancel)
If A = 2 Then Exit Sub

Dim SaveSheets As Variant
Dim strFilename As String
Dim sheetListRange As Range
Dim sheetName As Variant
Dim wksheet As Variant

Dim wkbSrc As Workbook
Dim wkbNew As Workbook
Dim wksNew As Worksheet
Dim wksSrc As Worksheet
Dim i As Integer
Dim OutApp As Object
Dim OutMail As Object
Dim v As Variant
Dim Jimmy As Variant

'On Error GoTo ErrorHandler
strFilename = Worksheets("Control").Range("SavePath").Value & "Ergonomie_Consultants_Performance_" & Format$(Now(), "YYYYMMDD") & ""
v = strFilename

Set sheetListRange = Worksheets("Control").Range("SaveList")
Set wkbSrc = ActiveWorkbook
Set wkbNew = Workbooks.Add
i = 0

For Each sheetName In sheetListRange
    If sheetName = "" Then GoTo NEXT_SHEET
    For Each wksheet In wkbSrc.Sheets
        If wksheet.Name = sheetName Then
            i = i + 1
            wksheet.Copy Before:=wkbNew.Sheets(i)
            Set wksNew = ActiveSheet
            With wksNew
                .Cells.Select
                .Cells.Copy
                .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
                .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
            End With
            ActiveWindow.Zoom = 75
            GoTo NEXT_SHEET
        End If
    Next wksheet
NEXT_SHEET:
Next sheetName

Application.DisplayAlerts = False
'dont need the default new sheets created by created a new workbook
wkbNew.Worksheets("Sheet1").Delete
ActiveWorkbook.SaveAs Filename:=v, FileFormat:=xlNormal

If VarType(v) <> vbString Then Exit Sub

If Dir(v) <> "" Then
    If MsgBox("File already exists - do you wish to overwrite it?", vbYesNo, "File Exists") = vbNo Then Exit Sub
End If

With ActiveWorkbook
    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=v, _
    Quality:=xlQualityStandard, IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, From:=1, To:=3, OpenAfterPublish:=False
End With

'  ActiveWorkbook.Close
' EMAIL  Attachment File
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
    .To = "[e-mail]"
    '        .CC = ""
    '        .BCC = ""
    .Subject = "Report" & Format$(Now(), "_YYYYMMDD")
    .Body = "DRAFT PLEASE REVIEW :Consultant Report" & Format$(Now(), "_YYYYMMDD")
    .Attachments.Add v & ".pdf"
    .Send
End With
On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
ActiveWorkbook.Close
Exit Sub

ErrorHandler:

'If there is an unknown runtime error give the user the error number and associated description
'(Description is already set if the erorr is G_LNG_CRITICAL_ERROR)
If Err.Number <> CRITICAL_ERROR Then Err.Description = "Run-time error " & Err.Number & ": " & Err.Description

Err.Description = "Error saving worksheet as file: " & Err.Description
Err.Source = "Error saving worksheet as file: " & Err.Source
'Raise the error up to the error handler above
Err.Raise Number:=CRITICAL_ERROR


End Sub      

1 个解决方案

#1

Try the section of code below instead of your 2 x For Each loops.

尝试下面的代码，而不是每个循环的2倍。

using Application.Match to find if the Sheet.Name is found within sheetListRange array (values read from Named Range "SaveList").

使用应用程序。匹配以找到是否页。在sheetListRange数组中可以找到Name(从命名范围“SaveList”中读取的值)。

Dim sheetListRange As Variant

' instead of saving the Range, save the values inside the Range in an Array
sheetListRange = Application.Transpose(Worksheets("Control").Range("SaveList"))

Set wkbSrc = ActiveWorkbook
Set wkbNew = Workbooks.Add

i = wkbNew.Sheets.Count
For Each wksheet In wkbSrc.Sheets
    ' instead of 2 X loops, use Application.Match
    If Not IsError(Application.Match(wksheet.Name, sheetListRange, 0)) Then ' worksheet match in "SaveList" Named Range
        wksheet.Copy Before:=wkbNew.Sheets(i)

        If Not wksheet.CodeName Like "Chart*" Then ' if current sheet is not type Chart
            Set wksNew = ActiveSheet
            With wksNew
                .Cells.Copy
                .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
                .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
            End With
        End If
        i = i + 1
        ActiveWindow.Zoom = 75
    End If
Next wksheet