0

我尝试了 VBA Express 提供的用于组合工作表的代码,在执行它时显示运行时错误 1004:应用程序定义或对象定义错误:

我的情况是:我有一个 Excel,因为我有第一张表“连接”,之后我有 Sheet1、Sheet2 等等。我通过说从 sheet2 开始合并除了工作表“连接”之外的所有工作表。

我尝试了以下代码行来排除“连接”表:
If Not Sheet.Name = "Connection" then
但它不起作用。

无论我在其中一些工作表中有什么工作表,我在一些单元格中都有大量数据。

这是我正在使用的代码:我已突出显示该行

Sub CopyFromWorksheets()
    Dim wrk As Workbook 'Workbook object - Always good to work with object variables
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Master Worksheet
    Dim rng As Range 'Range object
    Dim colCount As Integer 'Column count in tables in the worksheets

    Set wrk = ActiveWorkbook 'Working in active workbook

    For Each sht In wrk.Worksheets

        If sht.Name = "Master" Then
        sht.Delete

            Exit Sub
        End If
    Next sht

     'We don't want screen updating
    Application.ScreenUpdating = False

     'trg.SaveAs "C:\temp\CPReport1.xls"

     'Add new worksheet as the last worksheet
    Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))

     'Rename the new worksheet
    trg.Name = "Master"

     'Get column headers from the first worksheet
     'Column count first

    Set sht = wrk.Worksheets(2)

    colCount = sht.Cells(1, 255).End(xlToLeft).Column

     'Now retrieve headers, no copy&paste needed

    With trg.Cells(1, 1).Resize(1, colCount)
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
         'Set font as bold
        .Font.Bold = True
    End With

     trg.SaveAs "C:\temp\CPReport1.xls"

     'We can start loop

    'Skip Sheet - Connection
        If Not sht.Name = "Connection" Then
            For Each sht In wrk.Worksheets

                'If worksheet in loop is the last one, stop execution (it is Master worksheet)
                If sht.Index = wrk.Worksheets.Count Then
                Exit For
                End If

                'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
                Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
                'Put data into the Master worksheet
'-----------------  Error in below line --------------------------------------------------
                trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(rng.Rows.Count, rng.Columns.Count).Value = rng.Value
'----------------------------------------------------------------------------------------        
            Next sht

        End If

     'Fit the columns in Master worksheet
    trg.Columns.AutoFit

     'Dim dest, destyfile
     'dest = "E:\Test_Merge\"
     'destyfile = dest & "_" & trg.Name
     'trg.SaveAs (destyfile)
     'Screen updating should be activated
    Application.ScreenUpdating = True

End Sub
4

2 回答 2

2

第一个问题,如果您尝试排除连接表,则需要在循环内进行,而不是在外部进行。其次,让我们尝试粘贴值而不是范围转移。

        For Each sht In wrk.Worksheets
           'Skip Sheet - Connection
            If Not sht.Name = "Connection" and not sht.name="Master" Then

            'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
            Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
            'Put data into the Master worksheet
            rng.copy
            trg.Cells(rows.count, 1).End(xlUp).Offset(1).pastespecial paste:=xlpastevalues

            End If
        Next sht

完整的代码现在看起来像这样

Sub CopyFromWorksheets()
Dim wrk As Workbook 'Workbook object - Always good to work with object variables
Dim sht As Worksheet 'Object for handling worksheets in loop
Dim trg As Worksheet 'Master Worksheet
Dim rng As Range 'Range object
Dim colCount As Integer 'Column count in tables in the worksheets

Set wrk = ActiveWorkbook 'Working in active workbook

For Each sht In wrk.Worksheets

    If sht.Name = "Master" Then
    sht.Delete

        Exit Sub
    End If
Next sht

 'We don't want screen updating
Application.ScreenUpdating = False

 'trg.SaveAs "C:\temp\CPReport1.xls"

 'Add new worksheet as the last worksheet
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))

 'Rename the new worksheet
trg.Name = "Master"

 'Get column headers from the first worksheet
 'Column count first

Set sht = wrk.Worksheets(2)

colCount = sht.Cells(1, 255).End(xlToLeft).Column

 'Now retrieve headers, no copy&paste needed

With trg.Cells(1, 1).Resize(1, colCount)
    .Value = sht.Cells(1, 1).Resize(1, colCount).Value
     'Set font as bold
    .Font.Bold = True
End With

 'We can start loop

For Each sht In wrk.Worksheets
           'Skip Sheet - Connection
            If Not sht.Name = "Connection" and not sht.name="Master" Then

            'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
            Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
            'Put data into the Master worksheet
            rng.copy
            trg.Cells(rows.count, 1).End(xlUp).Offset(1).pastespecial paste:=xlpastevalues

            End If
        Next sht

'move out the Master sheet
trg.move
activeworkbook.SaveAs "C:\temp\CPReport1.xls"

 'Fit the columns in Master worksheet
trg.Columns.AutoFit

 'Dim dest, destyfile
 'dest = "E:\Test_Merge\"
 'destyfile = dest & "_" & trg.Name
 'trg.SaveAs (destyfile)
 'Screen updating should be activated
Application.ScreenUpdating = True

End Sub
于 2012-10-01T19:22:56.563 回答
0

我正在尝试使用指定位置的组合值保存名为“Cross Project Req Coverage”的主表。仅创建了 excel 工作表,但没有创建其中的值。当我们打开此母版表时,在状态栏中显示“选择目标并按 Enter 或选择粘贴。这是我的代码:

Sub CopyFromWorksheets()
    Dim wrk As Workbook 'Workbook object - Always good to work with object variables
    Dim sht As Worksheet 'Object for handling worksheets in loop
    Dim trg As Worksheet 'Master Worksheet
    Dim rng As Range 'Range object
    Dim colCount As Integer 'Column count in tables in the worksheets

    Set wrk = ActiveWorkbook 'Working in active workbook

    'We don't want screen updating
    Application.ScreenUpdating = False

    'Add new worksheet as the last worksheet
    'Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))

    Dim objcpExcel, objcpSheet
    Set objcpExcel = CreateObject("Excel.Application")
    objcpExcel.Workbooks.Add

    Set objcpSheet = objcpExcel.ActiveWorkbook.Worksheets(1)
    objcpSheet.Name = "Cross Project Reqs Coverage"

    'Rename the new worksheet
    'trg.Name = "Cross Project Reqs Coverage"

    Dim ws As Worksheet

    'For Each ws In ActiveWorkbook.Worksheets
       'If UCase(Left(ws.Name, 1)) = "S" Then ws.Visible = xlSheetVeryHidden
       'Next ws
    'Get column headers from the first worksheet
    'Column count first

    Set sht = wrk.Worksheets(2)

    colCount = sht.Cells(1, 255).End(xlToLeft).Column

    'Now retrieve headers, no copy&paste needed

    With objcpSheet.Cells(1, 1).Resize(1, colCount)
        .Value = sht.Cells(1, 1).Resize(1, colCount).Value
        .Font.Name = "Cambria"
        .Font.Bold = True
        .Font.ColorIndex = 2
        .Font.Size = 10
        .Interior.ColorIndex = 11
    End With

    'We can start loop

        For Each sht In wrk.Worksheets
           'Skip Sheet - Connection
            If Not sht.Name = "Connection" And Not sht.Name = "Cross Project Reqs  Coverage" Then

            'Data range in worksheet - starts from second row as first rows are the header rows in all worksheets
            Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 1).End(xlUp).Resize(, colCount))
            'Put data into the Master worksheet
            rng.Copy
            objcpSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

            End If
        Next sht

    'ActiveWorkbook.SaveAs "C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & CPDomain & "_" & CPProject & "_Requirement Coverage.xls"
    'Fit the columns in Master worksheet
    'objcpSheet.Columns.AutoFit

    'Screen updating should be activated
    Application.ScreenUpdating = True


Dim fso
Dim Project_fileCP As String

Dim ReportsFolderDestination
ReportsFolderDestination = "C:\Documents and Settings\All Users\Desktop\"
Project_fileCP = "C:\Documents and Settings\All Users\Desktop\" & "Cross Project Reqs Coverage.xls"

'Project_file1 = "C:\temp\" & project & "_Defects List.xls"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(Project_fileCP) Then
    fso.DeleteFile Project_fileCP, True
    objcpExcel.ActiveWorkbook.SaveAs (Project_fileCP)
    objcpExcel.Quit
    MsgBox " Cross Project Requirement Coverage Report Generated..Please check in QC Downloader Reports folder on Desktop!!!", vbInformation, "Cross Project Requirement Coverage Generated.. "
    Application.StatusBar = False

If Dir("C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & "Cross Project Reqs Coverage.xls") <> "" Then
    Kill "C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & "Cross Project Reqs Coverage.xls"
    OldFilePath = "C:\Documents and Settings\All Users\Desktop\" & "Cross Project Reqs Coverage.xls" ' original file location
    NewFilePath = "C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & "Cross Project Reqs Coverage.xls" ' new file location"
    Name OldFilePath As NewFilePath ' move the file
Else
    OldFilePath = "C:\Documents and Settings\All Users\Desktop\" & "Cross Project Reqs Coverage.xls" ' original file location
    NewFilePath = "C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & "Cross Project Reqs Coverage.xls" ' new file location"
    Name OldFilePath As NewFilePath ' move the file
End If
'Workbook_Deactivate
Else
    objcpExcel.ActiveWorkbook.SaveAs (Project_fileCP)
    objcpExcel.Quit
    'MsgBox " Defect List Created..Check on Desktop!!!", vbInformation, "Defect List Created.. "
    MsgBox " Cross Project Requirement Coverage Report Generated..Please check in QC Downloader Reports folder on Desktop!!!", vbInformation, "Cross Project Requirement Coverage Report Generated.. "

    Application.StatusBar = False

If Dir("C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & "Cross Project Reqs Coverage.xls") <> "" Then
    Kill "C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & "Cross Project Reqs Coverage.xls"
    OldFilePath = "C:\Documents and Settings\All Users\Desktop\" & "Cross Project Reqs Coverage.xls" ' original file location
    NewFilePath = "C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & "Cross Project Reqs Coverage.xls" ' new file location"
    Name OldFilePath As NewFilePath ' move the file
Else
    OldFilePath = "C:\Documents and Settings\All Users\Desktop\" & "Cross Project Reqs Coverage.xls" ' original file location
    NewFilePath = "C:\Documents and Settings\All Users\Desktop\QC Downloader Reports\" & "Cross Project Reqs Coverage.xls" ' new file location"
    Name OldFilePath As NewFilePath ' move the file
End If

End If

' If error occurs It will take care of that
ErrorHandling:
    If Err.Number <> 0 Then
        'MsgBox "Error Occurred.."
        MsgBox "Please check entered Path!!!", vbInformation, "Incorrect Value"
    End If



End Sub
于 2012-10-02T20:07:26.783 回答