应用程序定义的或对象定义的错误（1004） - Excel VBA

Question

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

从源每行中的特定细胞，如果在列“O”的内容是“否”，或者如果“j”列的内容是“初始”仅被复制。实际的源数据从第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。修复那些正常的引号应该照顾它。