錯誤：運行時錯誤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