Excel 对象定义错误_Excel_Vba - Fatal编程技术网

Excel 对象定义错误

excel vba

Excel 对象定义错误,excel,vba,Excel,Vba,我正在使用Excel2007。我正在使用一个宏，它将所有可见的工作表复制到新工作簿，并将保存为文本文件。我有超过12张纸，我必须从中复制至少10张。4张可见的图纸是副本，但在第五张图纸上，我发现应用程序定义错误或对象定义错误。我还有其他六张桌子。请帮我解决这个问题 Sub day_end_process() 'Working in 97-2010 Dim FileExtStr As String Dim FileFormatNum As Long Dim Sourcewb As Workboo

我正在使用Excel2007。我正在使用一个宏，它将所有可见的工作表复制到新工作簿，并将保存为文本文件。我有超过12张纸，我必须从中复制至少10张。4张可见的图纸是副本，但在第五张图纸上，我发现应用程序定义错误或对象定义错误。我还有其他六张桌子。请帮我解决这个问题

Sub day_end_process()

'Working in 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = Sourcewb.path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

    'If the sheet is visible then copy it to a new workbook
    If sh.Visible = -1 Then
        sh.Copy

        'Set Destwb to the new workbook
        Set Destwb = ActiveWorkbook

        'Determine the Excel version and file extension/format
        With Destwb
            FileExtStr = ".txt": FileFormatNum = -4158
        End With

        'Change all cells in the worksheet to values if you want
        'I get error in this if statement.

        If Destwb.Sheets(1).ProtectContents = False Then
            With Destwb.Sheets(1).UsedRange
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                .Cells(1).Select
            End With
            Application.CutCopyMode = False
        End If
        'Save the new workbook and close it
        With Destwb
            .SaveAs FolderName _
                  & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                    FileFormat:=FileFormatNum
            .Close False
        End With
    End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
Sheets("Main Page").Select
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
Sheets("Main Page").Select
ActiveWorkbook.Save

End Sub

代替

Sub day_end_process()

'Working in 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = Sourcewb.path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

    'If the sheet is visible then copy it to a new workbook
    If sh.Visible = -1 Then
        sh.Copy

        'Set Destwb to the new workbook
        Set Destwb = ActiveWorkbook

        'Determine the Excel version and file extension/format
        With Destwb
            FileExtStr = ".txt": FileFormatNum = -4158
        End With

        'Change all cells in the worksheet to values if you want
        'I get error in this if statement.

        If Destwb.Sheets(1).ProtectContents = False Then
            With Destwb.Sheets(1).UsedRange
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                .Cells(1).Select
            End With
            Application.CutCopyMode = False
        End If
        'Save the new workbook and close it
        With Destwb
            .SaveAs FolderName _
                  & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                    FileFormat:=FileFormatNum
            .Close False
        End With
    End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
Sheets("Main Page").Select
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
Sheets("Main Page").Select
ActiveWorkbook.Save

End Sub

    If Destwb.Sheets(1).ProtectContents = False Then 
        With Destwb.Sheets(1).UsedRange 
            .Cells.Copy 
            .Cells.PasteSpecial xlPasteValues 
            .Cells(1).Select 
        End With 
        Application.CutCopyMode = False 
    End If

也许可以试试：

Sub day_end_process()

'Working in 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = Sourcewb.path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

    'If the sheet is visible then copy it to a new workbook
    If sh.Visible = -1 Then
        sh.Copy

        'Set Destwb to the new workbook
        Set Destwb = ActiveWorkbook

        'Determine the Excel version and file extension/format
        With Destwb
            FileExtStr = ".txt": FileFormatNum = -4158
        End With

        'Change all cells in the worksheet to values if you want
        'I get error in this if statement.

        If Destwb.Sheets(1).ProtectContents = False Then
            With Destwb.Sheets(1).UsedRange
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                .Cells(1).Select
            End With
            Application.CutCopyMode = False
        End If
        'Save the new workbook and close it
        With Destwb
            .SaveAs FolderName _
                  & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                    FileFormat:=FileFormatNum
            .Close False
        End With
    End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
Sheets("Main Page").Select
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
Sheets("Main Page").Select
ActiveWorkbook.Save

End Sub

    If Destwb.Sheets(1).ProtectContents = False Then 
        Destwb.Sheets(1).UsedRange.value = Destwb.Sheets(1).UsedRange.value 
    End If

代替

Sub day_end_process()

'Working in 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = Sourcewb.path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

    'If the sheet is visible then copy it to a new workbook
    If sh.Visible = -1 Then
        sh.Copy

        'Set Destwb to the new workbook
        Set Destwb = ActiveWorkbook

        'Determine the Excel version and file extension/format
        With Destwb
            FileExtStr = ".txt": FileFormatNum = -4158
        End With

        'Change all cells in the worksheet to values if you want
        'I get error in this if statement.

        If Destwb.Sheets(1).ProtectContents = False Then
            With Destwb.Sheets(1).UsedRange
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                .Cells(1).Select
            End With
            Application.CutCopyMode = False
        End If
        'Save the new workbook and close it
        With Destwb
            .SaveAs FolderName _
                  & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                    FileFormat:=FileFormatNum
            .Close False
        End With
    End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
Sheets("Main Page").Select
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
Sheets("Main Page").Select
ActiveWorkbook.Save

End Sub

    If Destwb.Sheets(1).ProtectContents = False Then 
        With Destwb.Sheets(1).UsedRange 
            .Cells.Copy 
            .Cells.PasteSpecial xlPasteValues 
            .Cells(1).Select 
        End With 
        Application.CutCopyMode = False 
    End If

也许可以试试：

Sub day_end_process()

'Working in 97-2010
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim sh As Worksheet
Dim DateString As String
Dim FolderName As String

'Copy every sheet from the workbook with this macro
Set Sourcewb = ThisWorkbook

'Create new folder to save the new files in
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = Sourcewb.path & "\" & Sourcewb.Name & " " & DateString
MkDir FolderName

'Copy every visible sheet to a new workbook
For Each sh In Sourcewb.Worksheets

    'If the sheet is visible then copy it to a new workbook
    If sh.Visible = -1 Then
        sh.Copy

        'Set Destwb to the new workbook
        Set Destwb = ActiveWorkbook

        'Determine the Excel version and file extension/format
        With Destwb
            FileExtStr = ".txt": FileFormatNum = -4158
        End With

        'Change all cells in the worksheet to values if you want
        'I get error in this if statement.

        If Destwb.Sheets(1).ProtectContents = False Then
            With Destwb.Sheets(1).UsedRange
                .Cells.Copy
                .Cells.PasteSpecial xlPasteValues
                .Cells(1).Select
            End With
            Application.CutCopyMode = False
        End If
        'Save the new workbook and close it
        With Destwb
            .SaveAs FolderName _
                  & "\" & Destwb.Sheets(1).Name & FileExtStr, _
                    FileFormat:=FileFormatNum
            .Close False
        End With
    End If
GoToNextSheet:
Next sh
MsgBox "You can find the files in " & FolderName
Sheets("Main Page").Select
With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
End With
Sheets("Main Page").Select
ActiveWorkbook.Save

End Sub

    If Destwb.Sheets(1).ProtectContents = False Then 
        Destwb.Sheets(1).UsedRange.value = Destwb.Sheets(1).UsedRange.value 
    End If

第五份工作手册中是否有特定内容会导致其出错？另外，在此语句中，您实际在哪里创建新工作簿？根据您的代码，我无法区分为什么ActiveWorkbook与保存代码的源工作簿会有任何不同。如上所述，第5页中一定有导致问题的内容，错误发生在哪一行@ScottHoltzman“工作表复制”命令将工作表复制到一个新工作簿，然后该工作簿将变为活动工作簿workbook@Kyle-谢谢。我忽略了这一点@ScottHoltzman我猜表5可能是第一张看不见的表。如果前4个工作正常，那么问题一定会出现在

If

条件语句中，因为这是代码路径中唯一的更改。是否所有工作表都是工作表-没有图表工作表？第5个工作簿中是否存在导致出错的特定内容？另外，在此语句中，您实际在哪里创建新工作簿？根据您的代码，我无法区分为什么ActiveWorkbook与保存代码的源工作簿会有任何不同。如上所述，第5页中一定有导致问题的内容，错误发生在哪一行@ScottHoltzman“工作表复制”命令将工作表复制到一个新工作簿，然后该工作簿将变为活动工作簿workbook@Kyle-谢谢。我忽略了这一点@ScottHoltzman我猜表5可能是第一张看不见的表。如果前4个工作正常，则问题必须出现在

If

条件语句中，因为这是代码路径中唯一的更改。是否所有工作表都是工作表？是否没有图表工作表？