Macro to copy row to specific sheet in closed workbook

Hi,

is it allowed to open the workbook with vba and then close it again or is it used by another user?

Hi,

try these 2 files: Source.xlsm Target.xlsx

source contains:

Option Explicit

Private Sub cmdSubmit_Click()
    Dim xlWsActv As Worksheet, xlWsTrgt As Worksheet
    Dim xlRng As Range
    Dim aData
    Dim sAddr As String
    Dim i As Long, lngStart As Long
    
    On Error GoTo cmdSubmit_Click_ErrorHandler
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
    End With

    lngStart = 8 'first row of data

    Set xlWsActv = ActiveSheet
    With xlWsActv
        aData = .Range(.Cells(lngStart, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 6)).Value
        Set xlWsTrgt = Application.Workbooks.Open(.Cells(1, 1).Value).Worksheets(.Cells(2, 1).Value)
    End With
    
    With xlWsTrgt
        For i = LBound(aData, 1) To UBound(aData, 1)
            If Not IsEmpty(aData(i, 1)) Then
                Set xlRng = .Columns(1).Find(What:=aData(i, 1), LookIn:=xlValues, lookat:=xlWhole)
                If Not xlRng Is Nothing Then
                    sAddr = xlRng.Address
                    Do
                        If xlRng.Offset(, 1).Value = aData(i, 2) Then
                            xlRng.Offset(, 2).Resize(, 4).Value = _
                                    Array(aData(i, 3), aData(i, 4), aData(i, 5), aData(i, 6))
                                    
                            xlWsActv.Cells(i + lngStart - 1, 1).Resize(, 6).Clear
                            Exit Do
                        End If
                        Set xlRng = .Columns(1).FindNext(xlRng)
                        If xlRng Is Nothing Then Exit Do
                        If sAddr = xlRng.Address Then Exit Do
                    Loop
                End If
            End If
        Next i
    End With
    
cmdSubmit_Click_Proc_Exit:
    On Error GoTo 0
    If Not xlWsTrgt Is Nothing Then xlWsTrgt.Parent.Close True
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .DisplayAlerts = True
    End With
    Exit Sub
cmdSubmit_Click_ErrorHandler:
    MsgBox "Error: " & Err.Number & " (" & Err.Description & ") in Sub 'cmdSubmit_Click' of VBA Document 'Sheet1'.", vbOKOnly + vbCritical, "Error"
    Resume cmdSubmit_Click_Proc_Exit
End Sub

Hi,

did you experience that with the sample files with nothing changed except the filepath in source A1? very strange

Remove the code from the source and use this instead, the cells will not be cleared and the target will not be closed, inform me about any pop-ups or errors/crashes. We will implement everything back if we find out were the problem is.

Private Sub cmdSubmit_Click()
    Dim xlWsActv As Worksheet, xlWsTrgt As Worksheet
    Dim xlRng As Range
    Dim aData
    Dim sAddr As String
    Dim i As Long, lngStart As Long

    lngStart = 8 'first row of data

    Set xlWsActv = ActiveSheet
    With xlWsActv
        aData = .Range(.Cells(lngStart, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 6)).Value
        Set xlWsTrgt = Application.Workbooks.Open(.Cells(1, 1).Value).Worksheets(.Cells(2, 1).Value)
    End With
    
    With xlWsTrgt
        For i = LBound(aData, 1) To UBound(aData, 1)
            If Not IsEmpty(aData(i, 1)) Then
                Set xlRng = .Columns(1).Find(What:=aData(i, 1), LookIn:=xlValues, lookat:=xlWhole)
                If Not xlRng Is Nothing Then
                    sAddr = xlRng.Address
                    Do
                        If xlRng.Offset(, 1).Value = aData(i, 2) Then
                            xlRng.Offset(, 2).Resize(, 4).Value = _
                                    Array(aData(i, 3), aData(i, 4), aData(i, 5), aData(i, 6))
                                    
                        End If
                        Set xlRng = .Columns(1).FindNext(xlRng)
                        If xlRng Is Nothing Then Exit Do
                        If sAddr = xlRng.Address Then Exit Do
                    Loop
                End If
            End If
        Next i
    End With
End Sub

replace the if block with the following and run

                        If xlRng.Offset(, 1).Value = aData(i, 2) Then

                            xlRng.Offset(, 2).Value = aData(i, 3)
                            xlRng.Offset(, 3).Value = aData(i, 4)
                            xlRng.Offset(, 4).Value = aData(i, 5)
                            xlRng.Offset(, 5).Value = aData(i, 6)
                            MsgBox "ok"
                        End If

we expect a messagebox to appear 2 times