EXCEL VBA-从另一个Excel实例复制到活动工作簿时出错

Question

What I would like:

I need to be able to copy only certain columns from another instance (Application) of excel that will be open, depending on the header.

What I have so far:

Sub Import_Data()

Dim wb As Workbook
Dim c As Range
Dim headrng As Range
Dim lasthead As Range
Dim headrng1 As Range
Dim lasthead1 As Range
Dim LogDate As Range
Dim LastRow As Range
Dim BottomCell As Range
Dim MONTHrng As Range
Dim Lastrng As Range
Dim PRIhead As Range
Dim LOGhead As Range
Dim TYPEhead As Range
Dim CALLhead As Range
Dim DEShead As Range
Dim IPKhead As Range
Dim COPYrng As Range
Dim MONTHhead As Range
Dim YEARhead As Range

With ActiveWorkbook
    Application.ScreenUpdating = False
End With

'On Error GoTo ErrorHandle
Set wb = GetObject("Book1")

'If Book1 is found
If Not wb Is Nothing Then
    'Copy all Cells

    With wb.Worksheets("Sheet1")
        Set lasthead1 = .Range("1:1").Find(What:="*", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
        Set headrng1 = .Range("A1", lasthead1)
        For Each c In headrng1
            If Left(c, 1) = "-" Then c = Mid(c, 2, Len(c) - 1)
            If Left(c, 1) = "+" Then c = Mid(c, 2, Len(c) - 1)
        Next c

        'Insert new column and format it to the month value of log date
        Set LastRow = .Range("A:A").Find(What:="*", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByRows, SearchDirection:=xlPrevious)
        Set LogDate = headrng1.Find(What:="Log Date", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        Set BottomCell = .Cells(LastRow.Row, LogDate.Offset(0, 1).Column)
        LogDate.EntireColumn.Offset(0, 1).Insert
        LogDate.EntireColumn.Offset(0, 1).Insert
        Set MONTHrng = .Range(LogDate.Offset(0, 1), BottomCell.Offset(0, -2))
        MONTHrng = "=Month(RC[-1])"
        MONTHrng.Offset(0, 1) = "=Year(RC[-2])"
        LogDate.Offset(0, 1).Value = "Month Number"
        LogDate.Offset(0, 2).Value = "Year Number"
        MONTHrng.EntireColumn.NumberFormat = "General"
        MONTHrng.Offset(0, 1).EntireColumn.NumberFormat = "General"


        Set PRIhead = headrng1.Find(What:="Priority", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        Set LOGhead = headrng1.Find(What:="Log Date", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        Set TYPEhead = headrng1.Find(What:="Type", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        Set CALLhead = headrng1.Find(What:="Call Status", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        Set DEShead = headrng1.Find(What:="Description", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        Set IPKhead = headrng1.Find(What:="IPK Status", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        Set MONTHhead = headrng1.Find(What:="Month Number", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        Set YEARhead = headrng1.Find(What:="Year Number", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlNext)
        PRIhead.EntireColumn.Copy
    End With

ActiveWorkbook.Worksheets("RAW Data").Cells.Clear
    With ActiveWorkbook.Worksheets("RAW Data")
        'Paste Values
        .Range("A1").PasteSpecial xlPasteValues
    End With

    With wb.Worksheets("Sheet1")
        wb.Application.CutCopyMode = False
        LOGhead.EntireColumn.Copy
    End With

    With ActiveWorkbook.Worksheets("RAW Data")
        'Paste Values
        .Range("B1").PasteSpecial xlPasteValues
    End With

    With wb.Worksheets("Sheet1")
        wb.Application.CutCopyMode = False
        MONTHhead.EntireColumn.Copy
    End With

    With ActiveWorkbook.Worksheets("RAW Data")
        'Paste Values
        .Range("C1").PasteSpecial xlPasteValues
    End With

    With wb.Worksheets("Sheet1")
        wb.Application.CutCopyMode = False
        YEARhead.EntireColumn.Copy
    End With

    With ActiveWorkbook.Worksheets("RAW Data")
        'Paste Values
        .Range("D1").PasteSpecial xlPasteValues
    End With

    With wb.Worksheets("Sheet1")
        wb.Application.CutCopyMode = False
        TYPEhead.EntireColumn.Copy
    End With

    With ActiveWorkbook.Worksheets("RAW Data")
        'Paste Values
        .Range("E1").PasteSpecial xlPasteValues
    End With

    With wb.Worksheets("Sheet1")
        wb.Application.CutCopyMode = False
        CALLhead.EntireColumn.Copy
    End With

    With ActiveWorkbook.Worksheets("RAW Data")
        'Paste Values
        .Range("F1").PasteSpecial xlPasteValues
    End With

    With wb.Worksheets("Sheet1")
        wb.Application.CutCopyMode = False
        DEShead.EntireColumn.Copy
    End With

    With ActiveWorkbook.Worksheets("RAW Data")
        'Paste Values
        .Range("G1").PasteSpecial xlPasteValues
    End With

    With wb.Worksheets("Sheet1")
        wb.Application.CutCopyMode = False
        IPKhead.EntireColumn.Copy
    End With

    With ActiveWorkbook.Worksheets("RAW Data")
        'Paste Values
        .Range("H1").PasteSpecial xlPasteValues

        'Set Cells height to 15
        .Cells.RowHeight = 15
        'Set all Columsn to Autofit
        .Cells.Columns.AutoFit
    End With

    'Clear the clipboard
    wb.Application.CutCopyMode = False
    'Close the Book1
    wb.Close False

Else
    'If no Book1 found display output
    MsgBox "Please ensure that you have opened the data from infra"
End If

With ActiveWorkbook.Worksheets("RAW Data")
    'Set all Headers as Range
    Set lasthead = .Range("1:1").Find(What:="*", LookAt:=xlPart, MatchCase:=False, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious)
    Set headrng = .Range("A1", lasthead)

    'Remove - or + from headers
    For Each c In headrng
        If Left(c, 1) = "-" Then c = Mid(c, 2, Len(c) - 1)
        If Left(c, 1) = "+" Then c = Mid(c, 2, Len(c) - 1)
    Next c




End With
ErrorHandle:

With ActiveWorkbook
    Application.ScreenUpdating = True
End With

MsgBox "New Data has been Imported"

End Sub

What doesn't work:

The issue appears to be with the past function.

The error code:

PasteSpecial method of Range class failed

when debugging it highlights any of the following example of code:

.Range("F1").PasteSpecial xlPasteValues

My Findings:

At the moment I am having issues pinning this down to an exact point of failure. It seems to be random as to which paste fails. Sometimes the function completes without issue at all. The only thing that I can think off that appears to get it to work each time is to have the worksheet I am pasting on to active BEFORE I run the macro. The reason for thinking this is because when I select to debug it, the worksheet makes the "RAW Data" sheet active and then when I press either F8 or F5 to debug or run the code. It works without making any other changes.

Other Notes:

• The workbook I am copying from is data exported from another application and I am wanting to fully automate a process. Therefore, this workbook has not been selected before the macro run. I am not sure if that would have any bearing on this issue?

Answer 1

尝试类似的东西，

.Range("G1").PasteSpecial(XlPasteType.xlPasteValues)