错误：运行时错误9下标超出范围：为数据复制分配工作表变量时

Question

Although this is common error and I tried to find relevant topics but failed to learn to fix my code. I'm trying to copy certain cells of Excel sheet for a particular vendor when we receive updates from them, to avoid manual copy. I see this error at

Set Source = Workbooks(strFileName).Worksheets("Demand Request Details")

step. Please help.

Sub MergeInflight01()
    Dim j As Long
    Dim i As Long
    Dim Ret
    Dim wbk As Workbook
    Dim numofrows As Long
    Dim strFileName As String
    Dim strVendorName As String
    Dim Source As Worksheet, Destination As Worksheet
    Dim arrA(1 To 15, 1 To 2) As Variant

    Sheets("Demand Request Details").Select

    strFileName = InputBox("Please Enter the source file with Path to take data from")
    strVendorName = InputBox("Please Enter the Vendor name from XYZ")

    If FileInUse(strFileName) Then
        ' Open the work-book if not opened already
        Set wkbSource = Workbooks.Open(strFileName)
    End If

    'ERROR HERE
    Set Source = Workbooks(strFileName).Worksheets("Demand Request Details")

    numofrows = Sheet4.Cells(Rows.Count, 1).End(xlUp).Row + 5
    strFileName = InputBox("Please Enter the Destination file with Path to take data from")

    If FileInUse(strFileName) Then
        ' Open the work-book if not opened already
        Set wkbSource = Workbooks.Open(strFileName)
    End If


    Set Destination = Workbooks(strFileName).Worksheets("Demand Request Details")

    For i = 1 To numofrows
       If (Source.Cells(i, 22).Value = "DELIVERY") And (Source.Cells(i, 14).Value = strVendorName) Then
         For j = 1 To numofrows
            If (Source.Cells(i, 1).Value = Destination.Cells(j, 1).Value) And (Source.Cells(i, 6).Value = Destination.Cells(j, 6).Value) Then
             Source.Cells(i, 20).Value = Destination.Cells(j, 20).Value
             Source.Cells(i, 38).Value = Destination.Cells(j, 38).Value
             Source.Cells(i, 39).Value = Destination.Cells(j, 39).Value
             Source.Cells(i, 40).Value = Destination.Cells(j, 40).Value
             Source.Cells(i, 41).Value = Destination.Cells(j, 41).Value
             Source.Cells(i, 42).Value = Destination.Cells(j, 42).Value
            ElseIf (Source.Cells(i, 1).Value = Destination.Cells(j, 1).Value) And (Source.Cells(i, 6).Value <> Destination.Cells(j, 6).Value) Then
             Source.Cells(i, 1).Interior.ColorIndex = 3
            End If
         Next j
       End If
    Next i

End Sub

Public Function FileInUse(sFileName) As Boolean
    On Error Resume Next
    Open sFileName For Binary Access Read Lock Read As #1
    Close #1
    FileInUse = IIf(Err.Number > 0, True, False)
    On Error GoTo 0
End Function

Answer 1

Also instead of using an input box for the user to enter the file name and path, use Application.GetOpenFilename

Also you need to extract the file name from the full path so you can work with an already open workbook.

Is this what you are trying?

Sub MergeInflight01()
    Dim wkbSource As Workbook
    Dim Filetoopen
    Dim WBName As String

    '~~> Let user select the file
    Filetoopen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*")

    If Filetoopen <> False Then
        WBName = GetFilenameFromPath(Filetoopen)

        If IsWorkBookOpen(WBName) Then
            Set wkbSource = Workbooks(WBName).Worksheets("Demand Request Details")
        Else
            Set wkbSource = Workbooks.Open(Filetoopen)
        End If

        '
        '~~> Rest of the code
        '

    End If
End Sub

'~~> Check if the Workbook is open
Function IsWorkBookOpen(FileName)
    Dim ff As Long, ErrNo As Long

    On Error Resume Next
    ff = FreeFile()
    Open FileName For Input Lock Read As #ff
    Close ff
    ErrNo = Err
    On Error GoTo 0

    Select Case ErrNo
    Case 0:    IsWorkBookOpen = False
    Case 70:   IsWorkBookOpen = True
    Case Else: Error ErrNo
    End Select
End Function

'~~> Get filename from path
Public Function GetFilenameFromPath(ByVal strPath As String) As String
    If Right$(strPath, 1) <> "\" And Len(strPath) > 0 Then
        GetFilenameFromPath = _
        GetFilenameFromPath(Left$(strPath, Len(strPath) - 1)) + Right$(strPath, 1)
    End If
End Function