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

Question

虽然这是常见错误，但我尝试查找相关主题，但未能学会修复代码。 当我们收到来自特定供应商的更新时，我正在尝试为它们复制Excel工作表的某些单元格，以避免手动复制。 我在看到这个错误

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

步。 请帮忙。

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

同样，不要使用供用户输入文件名和路径的输入框，而应使用Application.GetOpenFilename

另外，您需要从完整路径中提取文件名，以便可以使用已经打开的工作簿。

这是您要尝试的吗？

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