运行时错误“I004”：应用程序定义或对象定义错误

Question

我收到此错误。我的所有数据都在 targetArray 中，大约有 152 行。但它只粘贴了 81 行，我得到了这个错误。

当它尝试在代码中运行以下行时出现错误：

WBook.Worksheets(strWorksheet).Range(strAddress).Value = TargetArray
Set WBook = Nothing

我的主要代码是

Sub GetData(Optional OnOpen As Boolean = False)

Dim vrntQryList() As Variant
Dim vrntQryData() As Variant
Dim vrntRptGrp() As Variant
Dim intQryListCol As Integer
Dim strQry As String
Dim strRptGrp As String

'This subroutine imports new data. The OnOpen indicator modifies where the data is put after it runs

On Error GoTo GameOver

'choose which column to look for the range name based on whether or not this is run on open or not
If OnOpen Then
    intQryListCol = 3
Else
    intQryListCol = 2
End If

'Get the list of queries
vrntQryList = AF_RngToArray("DT_QryList")
vrntRptGrp = AF_RngToArray("DT_RptGrp")

'Make the report groups a list
strRptGrp = VF_ArrayToList(vrntRptGrp, 1)

'Loop through the query list
For i = 1 To UBound(vrntQryList)

    If vrntQryList(i, intQryListCol) <> "" Then

        'Set the query to this variable so we can run the replace function to get placeholders
        strQry = vrntQryList(i, 1)
        strQry = Replace(strQry, "|USERID|", Environ("Username"))
        strQry = Replace(strQry, "|RPTGRP|", strRptGrp)

        'Get the new data from the database
        vrntQryData = AF_QryToArray_AXS(ThisWorkbook.Names("DT_DBPath").RefersToRange.Value, strQry)

        'Only continue and clear out the ranges if we know that we returned new data
        If SafeUbound(vrntQryData) <> 0 Then

            ThisWorkbook.Names(vrntQryList(i, intQryListCol)).RefersToRange.ClearContents

            Call PasteArray(vrntQryData, CStr(vrntQryList(i, intQryListCol)))
        Else
            GoTo GameOver
        End If

    End If

Next i

Exit Sub

'If there's an error just back out and let the user know
GameOver:

'If we make it down here and we are not running with the OnOpen indicator set to TRUE then let the user know we don't have new data for them
If Not OnOpen Then
    MsgBox "Error importing new data. Most likely you don't have access to the required LAN drive.", , "ERROR IN DATA IMPORT"
End If

End Sub

---

Sub PasteArray(TargetArray() As Variant, RangeName As String, Optional blNotThisWorkbook As Boolean = False)

'The purpose of this function is to be able to transfer data from an array in VBA back into a
'named range in excel

Dim strWorksheet As String
Dim strAddress As String
Dim cntRows As Long
Dim cntCols As Long
Dim WBook As Workbook
Dim rngCols As Long
Dim rngRows As Long

'Check if the array is empty, if it is then exit the sub
If SafeUbound(TargetArray) = 0 Then Exit Sub

If blNotThisWorkbook Then
    Set WBook = ActiveWorkbook
Else
    Set WBook = ThisWorkbook
End If

'Clear out the paste range to start
WBook.Names(RangeName).RefersToRange.ClearContents

'Find the name of the target worksheet
strWorksheet = WBook.Names(RangeName).RefersToRange.Worksheet.Name

'Find the size of the range we are pasting to
rngCols = WBook.Names(RangeName).RefersToRange.Columns.Count
rngRows = WBook.Names(RangeName).RefersToRange.Rows.Count

'Find the number of rows and columns
cntRows = UBound(TargetArray)
cntCols = UBound(TargetArray, 2)

'Check to make sure the array will fit in the range we are pasting to.
'trip an error here if desired
If cntRows > rngRows Or cntCols > rngCols Then
    Set WBook = Nothing
    Exit Sub
End If

'Get the exact size of the range, based on the amount of data in it
SplitAd = Split(WBook.Names(RangeName).RefersToRange.Address, ":")
strAddress = SplitAd(0) & ":" & Range(SplitAd(0)).Offset(cntRows - 1, cntCols - 1).Address

'Drop down the array into the range
WBook.Worksheets(strWorksheet).Range(strAddress).Value = TargetArray
Set WBook = Nothing

End Sub

Answer 1

假设 TargetArray 是一个基于 1 的二维数组：

WBook.Worksheets(strWorksheet).Range(strAddress).Cells(1).Resize( _
    UBound(TargetArray, 1), UBound(TargetArray, 2)).Value = TargetArray