Application-defined or object-defined error (1004) - Excel VBA

Question

I have a workbook called 'EvaluationLog.xlsm' and I need to transfer specific cells (not the whole row) from the first worksheet to another existing workbook called 'IndicatorLog.xlsm' located in the same directory. The target worksheet is also the first one. I'm trying to have the macro hosted in the 'IndicatorLog' workbook.

Specific cells in each row from the source are only to be copied if the contents in column 'O' is 'No' or if the contents of column 'J' is 'Initial'. The actual source data starts on row 8 and the target range also starts on row 8.

I'm having two issues. The first one is that I'm getting this error 'Application-defined or object-defined error (1004)' at the first line where I'm trying to copy cells.

This is the line: TargetSheet.Range("A" & NRow).Value = WorkBk.ActiveSheet.Range(“A” & i).Value

The second issue is that when I already have the source workbook open, I get a warning about trying to open it again even though I have a function to try to avoid that. :(

I assigned the macro to a form button. Any help will be greatly appreciated! :)

Here are the two Excel files:

Files

Here's the code:

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

I don't think `CheckFileIsOpen` will do what you want it to. Try [this](http://stackoverflow.com/questions/9373082/detect-whether-excel-workbook-is-already-open-using-vba) instead, maybe. — Matt Cremeens, Jul 20 '15 at 21:06
Try fixing your syntax `“A”` - should be `"A"` that should fix your Error (1004) — 0m3r, Jul 20 '15 at 21:12
@ClaudiaLorena don't forgot to [accept an answer](http://meta.stackexchange.com/questions/5234/how-does-accepting-an-answer-work) that help you out — 0m3r, Jul 20 '15 at 23:49

score 1 · Answer 1 · answered Jul 20 '15 at 21:47

1

Change your function call:

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

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

CheckFileIsOpen = ret

End Function

Otherwise, the ironically-named smart quotes don't work well (or, they don't work at all) with VBA. Fixing those to normal quotes should take care of it.

answered Jul 20 '15 at 21:47

David Zemens

53,033
11
81
130

Thank you very, very much! :) – Claudia Lorena Jul 20 '15 at 22:50

score 1 · Accepted Answer · answered Jul 20 '15 at 21:59

You can take advantage of the rarely used Resume with error control.

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

The error trapping with Resume completely negates the need for your function.

I was able to run the macro and it did copy the cells, but they went to the very last row in the target workbook. I replaced this NRow = TargetSheet.Cells(Rows.Count, 1).End(xlUp).Row + 1 with this NRow = 8 and it worked! Thanks again! :) :) — Claudia Lorena, Jul 20 '15 at 23:04
[Glad to hear you got sorted out quickly](http://stackoverflow.com/help/someone-answers). Sorry about rewriting the target row. — , Jul 20 '15 at 23:06

Application-defined or object-defined error (1004) - Excel VBA

2 Answers2