Question

我有一个代码可以将工作簿复制到一个新的工作簿中，仅保留其价值。在工作簿中应有一个命名范围“ NotCopy”，以指示将不复制到新文件中的工作表数。问题是我遇到了至少3种1004错误类型。

存在工作表名称（原始文件的工作表名称如“ Sheet1”时）newSheet.Name = sh.Name将引发错误
找不到命名范围。 Set r = ActiveWorkbook.Names("NotCopy").RefersToRange将引发错误
同名文件正在打开，.SaveAs的操作将出错。

如果我使用如下代码，它将无法正确处理不同的错误情况。我该怎么办？

Sub CopyWorkbookValue()

On Error GoTo ErrorHandler

Dim Output As Workbook, Source As Workbook
Dim sh As Worksheet
Dim FileName As String
Dim OriginalName As String
Dim firstCell
Dim NotCopySheet As Integer
Dim r As Range

OriginalName = ActiveWorkbook.Name
'Copy into no macro file only. Rename .xlsm into .xlsx
If Right(OriginalName, 1) = "m" Then
    OriginalName = Left(OriginalName, Len(OriginalName) - 1) & "x"
End If

Set r = ActiveWorkbook.Names("NotCopy").RefersToRange
NotCopySheet = r.Cells(1, 1).Value

StartCopying:
MsgBox "The number of sheet ignore is " & NotCopySheet
MsgBox "This macro cannot work with merged cell." & vbNewLine & "If there is merged cell, operation will not be completed successfully." & vbNewLine & "Remove all merged cell in ALL sheets before use"

Application.ScreenUpdating = False
Set Source = ActiveWorkbook
Set Output = Workbooks.Add
'Set a unique name so it cannot be the same as the original file
Output.Sheets(1).Name = "Sheet (0)"
Application.DisplayAlerts = False

Dim i As Integer

For Each sh In Source.Worksheets
    If sh.Index <= NotCopySheet Then
    Else

    Dim newSheet As Worksheet

    ' select all used cells in the source sheet:
    sh.Activate
    sh.UsedRange.Select
    Application.CutCopyMode = False
    Selection.Copy

    ' create new destination sheet:
    Set newSheet = Output.Worksheets.Add(After:=Output.Worksheets(Output.Worksheets.Count))
    newSheet.Name = sh.Name

    ' make sure the destination sheet is selected with the right cell:
    newSheet.Activate
    firstCell = sh.UsedRange.Cells(1, 1).Address
    newSheet.Range(firstCell).Select

    ' paste the values:
    Range(firstCell).PasteSpecial Paste:=xlPasteFormats
    Range(firstCell).PasteSpecial Paste:=xlPasteColumnWidths
    Range(firstCell).PasteSpecial Paste:=xlPasteValues, _
    Operation:=xlNone, SkipBlanks:=True, Transpose:=False
    End If
Next

' delete the empty sheet created when new book created.
If NotCopySheet = 0 Then
    Output.Sheets(1).Delete
End If

FileName = "C:\Dropbox\0 EPAS Export\ValueOnly_" & OriginalName
Output.SaveAs FileName
'Output.Close
Application.ScreenUpdating = True

Exit Sub
ErrorHandler:
    'MsgBox "Error number is " & Err.Number
    Select Case Err.Number   ' Evaluate error number.
        Case 1004   ' Range NotCopy not found
            NotCopySheet = 0
            MsgBox "Range NotCopy is not defined in this workbook, all sheet will be copied"
            GoTo StartCopying

        Case Else
            MsgBox "Something went wrong"
            Exit Sub
    End Select
    Resume Next

End Sub

如何处理错误1004的许多不同类型的错误

0 个答案: