应用程序定义或对象定义错误 (1004) - Excel VBA

Question

我有一个名为“EvaluationLog.xlsm”的工作簿，我需要将第一个工作表中的特定单元格（不是整行）转移到位于同一目录中的另一个名为“IndicatorLog.xlsm”的现有工作簿中。目标工作表也是第一个。我正在尝试将宏托管在“IndicatorLog”工作簿中。

仅当“O”列中的内容为“No”或“J”列中的内容为“Initial”时，才会复制源中每一行中的特定单元格。实际源数据从第 8 行开始，目标范围也从第 8 行开始。

我有两个问题。第一个是我在尝试复制单元格的第一行收到此错误“应用程序定义或对象定义错误（1004）”。

这是线路：TargetSheet.Range("A" & NRow).Value = WorkBk.ActiveSheet.Range(“A” & i).Value

第二个问题是，当我已经打开源工作簿时，我会收到关于尝试再次打开它的警告，即使我有一个功能可以避免这种情况。 :(

我将宏分配给表单按钮。任何帮助将不胜感激！ :)

这是两个 Excel 文件：

Files

代码如下：

Sub MergeFromLog()

Dim TargetSheet As Worksheet
Dim NRow As Long
Dim SourceFileName As String
Dim WorkBk As Workbook
Dim LastRow As Integer, i As Integer, erow As Integer

' Set destination file.
Set TargetSheet = ActiveWorkbook.Worksheets(1)

' Set source file.
SourceFileName = ActiveWorkbook.Path & "\2015-2016 Evaluation Log.xlsm"

' NRow keeps track of where to insert new rows in the destination workbook.
NRow = 8

' Open the source workbook in the folder
If CheckFileIsOpen(SourceFileName) = False Then
    Set WorkBk = Workbooks.Open(SourceFileName)
Else
    Set WorkBk = Workbooks(SourceFileName)
End If

LastRow = WorkBk.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row

For i = 8 To LastRow

    If WorkBk.ActiveSheet.Range("O" & i) = "No" Or WorkBk.ActiveSheet.Range("J" & i) = "Initial" Then

        ' Copy Student Name
        TargetSheet.Range("A" & NRow).Value = WorkBk.ActiveSheet.Range(“A” & i).Value
        ' Copy DOB
        TargetSheet.Range("B" & NRow).Value = WorkBk.ActiveSheet.Range(“C” & i).Value
        ' Copy ID#
        TargetSheet.Range("C" & NRow).Value = WorkBk.ActiveSheet.Range(“D” & i).Value
        ' Copy Consent Day
        TargetSheet.Range("D" & NRow).Value = WorkBk.ActiveSheet.Range(“L” & i).Value
        ' Copy Report Day
        TargetSheet.Range("E" & NRow).Value = WorkBk.ActiveSheet.Range(“N” & i).Value
        ' Copy FIE within District Timelines?
        TargetSheet.Range("F" & NRow).Value = WorkBk.ActiveSheet.Range(“O” & i).Value
        ' Copy Qualified?
        TargetSheet.Range("H" & NRow).Value = WorkBk.ActiveSheet.Range(“A” & i).Value
        ' Copy Primary Eligibility
        TargetSheet.Range("I" & NRow).Value = WorkBk.ActiveSheet.Range(“U” & i).Value
        ' Copy ARD Date
        TargetSheet.Range("J" & NRow).Value = WorkBk.ActiveSheet.Range(“R” & i).Value
        ' Copy ARD within District Timelines?
        TargetSheet.Range("K" & NRow).Value = WorkBk.ActiveSheet.Range(“S” & i).Value
        ' Copy Ethnicity
        TargetSheet.Range("M" & NRow).Value = WorkBk.ActiveSheet.Range(“F” & i).Value
        ' Copy Hisp?
        TargetSheet.Range("N" & NRow).Value = WorkBk.ActiveSheet.Range(“G” & i).Value
        ' Copy Diag/LSSP
        TargetSheet.Range("O" & NRow).Value = WorkBk.ActiveSheet.Range(“X” & i).Value

        NRow = NRow + 1

    End If

Next i

End Sub

Function CheckFileIsOpen(chkSumfile As String) As Boolean

On Error Resume Next

CheckFileIsOpen = UCase(Workbooks(chkSumfile).Name) Like UCase(chkSumfile)

On Error GoTo 0

End Function

Answer 1

您可以利用很少使用的Resume 进行错误控制。

Sub MergeFromLog2()

    Dim SourceSheet As Worksheet, TargetSheet As Worksheet
    Dim SourceFileName As String
    Dim LastRow As Long, i As Long, NRow As Long

    ' Set destination file.
    Set TargetSheet = ThisWorkbook.Worksheets(1)
    NRow = TargetSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1

    ' Set source file.
    On Error GoTo CheckWbIsOpen
    SourceFileName = ThisWorkbook.Path & "\2015-2016 Evaluation Log.xlsm"
    'Try to work on it as if it was open. If it is closed an error will be thrown and it will be opened and control will be returned back here
    Set SourceSheet = Workbooks(Trim(Right(Replace(SourceFileName, "\", Space(99)), 99))).Worksheets(1)
    On Error GoTo 0

    With SourceSheet
        Debug.Print .Name
        LastRow = .Cells(Rows.Count, "A").End(xlUp).Row

        For i = 8 To LastRow
            If .Range("O" & i) = "No" Or .Range("J" & i) = "Initial" Then

                ' Copy Student Name
                TargetSheet.Range("A" & NRow).Value = .Range("A" & i).Value
                ' Copy DOB
                TargetSheet.Range("B" & NRow).Value = .Range("C" & i).Value
                ' Copy ID#
                TargetSheet.Range("C" & NRow).Value = .Range("D" & i).Value
                ' Copy Consent Day
                TargetSheet.Range("D" & NRow).Value = .Range("L" & i).Value
                ' Copy Report Day
                TargetSheet.Range("E" & NRow).Value = .Range("N" & i).Value
                ' Copy FIE within District Timelines?
                TargetSheet.Range("F" & NRow).Value = .Range("O" & i).Value
                ' Copy Qualified?
                TargetSheet.Range("H" & NRow).Value = .Range("A" & i).Value
                ' Copy Primary Eligibility
                TargetSheet.Range("I" & NRow).Value = .Range("U" & i).Value
                ' Copy ARD Date
                TargetSheet.Range("J" & NRow).Value = .Range("R" & i).Value
                ' Copy ARD within District Timelines?
                TargetSheet.Range("K" & NRow).Value = .Range("S" & i).Value
                ' Copy Ethnicity
                TargetSheet.Range("M" & NRow).Value = .Range("F" & i).Value
                ' Copy Hisp?
                TargetSheet.Range("N" & NRow).Value = .Range("G" & i).Value
                ' Copy Diag/LSSP
                TargetSheet.Range("O" & NRow).Value = .Range("X" & i).Value

                NRow = NRow + 1

            End If

        Next i
        Application.DisplayAlerts = False
        .Parent.Close False
    End With

    GoTo Safe_Exit
CheckWbIsOpen:
    i = i + 1
    If i > 1 Then
        'tried once and failed - do not keep trying to open something that doesn't want to be opened
        Debug.Print "Unable to open: " & SourceFileName
        Exit Sub
    End If
    Workbooks.Open Filename:=SourceFileName, ReadOnly:=True
    Resume  '<- this sends control back to the line that threw the error
Safe_Exit:
    Set SourceSheet = Nothing
    Set TargetSheet = Nothing
    Application.DisplayAlerts = True
End Sub

Resume 的错误捕获完全否定了您对函数的需求。

Answer 2

改变你的函数调用：

Function CheckFileIsOpen(chkSumfile As String) As Boolean
Dim ret 
ret = False
On Error Resume Next

ret = (Workbooks(chkSumfile).Name <> "")

CheckFileIsOpen = ret

End Function

否则，具有讽刺意味的 智能引号 在 VBA 中不能很好地工作（或者，它们根本不能工作）。将它们修复为正常引号应该会处理它。