Question

工作表列表在名称范围“SaveList”中指定，其中一些作为工作表，一些作为图表（整页），但它随着

而失效

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

以下常规代码

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 = "waverley.inc@gmail.com"
    '        .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

Answer 1

尝试下面的代码部分而不是2 x For Each循环。

使用Application.Match查找是否在Sheet.Name数组中找到sheetListRange（从命名范围“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

我有一个例程，将工作簿中的指定工作表保存到pdf文档但是如果我制作一些工作表图表，我的例程就会丢失

1 个答案: