Question

我是VBA的新手和一般的编程（以及堆栈溢出）。我有一个包含三个工作表的工作簿。我试图将一张表格的第1列中的值列表与另一张图纸上的大型数据表的第2列进行比较。如果它们匹配，我想将该行复制到第三张表上的表中。我有没有数组工作（类似的循环，直接在工作表/范围上工作），但它太慢了，虽然它通常成功完成，但它经常使Excel陷入困境，所以我去了数组。

我设法将源数据和查找值放到数组中，我可以遍历数组并在任何单个单元格中检索预期的数据（我已经使用中间窗口和debug.print来检查变量和有关数组值的详细信息）。

我无法弄清楚最后几件。对于每个匹配的行，我试图将每个单元从数据阵列复制到目标阵列。填充目标数组时，我想将其转储到第三个工作表的表中。

我在这里得到运行时424对象所需的错误：

TargetArray(k, j) = DataArray(i, j).Value

我可以将TargetArray中的每个值直接写回目标表，但这似乎并不比无数组方式快。

一旦我能做到这一点，我就会这样做，我相信这会奏效：

TargetArray = DataArray

我花了好几天时间做了数百次搜索和大量阅读以达到这一点，但我很难过。

是否有任何技巧可以让我将一个值从一个数组写入另一个数组？
如果没有，如何在不触及工作表数千次的情况下将行从一个表复制到另一个表？（又名＆＃34;知道他们正在做什么的人怎么会这样做？＆＃34;）

毫无疑问，我的代码有不必要的步骤和其他问题。所有建议都表示赞赏。

以下是所有代码：

Option Explicit
Option Base 1
Sub CopyMatchingRows()
Dim DataArray() As Variant, CriteriaArray() As Variant, TargetArray As Variant
Dim DataRange As Range, CriteriaRange As Range, TargetRange As Range
Dim rCountData As Integer, rCountCriteria As Integer, rCountTarget As Integer 'row counts
Dim cCountData As Integer, cCountCriteria As Integer, cCountTarget As Integer 'col counts

Dim LookupValue As Variant 'lookup value

Dim h As Integer, i As Integer, j As Integer, k As Integer 'counters

'define ranges from tables
Set DataRange = Worksheets("SourceData").ListObjects("DataTable").Range
Set CriteriaRange = Worksheets("SchoolList").ListObjects("SchoolListTable").Range
Set TargetRange = Worksheets("SchoolData").ListObjects("SchoolDataTable").DataBodyRange

'turn screen updating back on
Application.ScreenUpdating = False

'clear target range contents
'TargetRange.ClearContents

'define row and column count variables
rCountData = DataRange.Rows.Count
rCountCriteria = CriteriaRange.Rows.Count
rCountTarget = TargetRange.Rows.Count
cCountData = DataRange.Columns.Count
cCountCriteria = CriteriaRange.Columns.Count
cCountTarget = TargetRange.Columns.Count

'dimension arrays
ReDim DataArray(rCountData, cCountData)
ReDim CriteriaArray(rCountCriteria, cCountCriteria)


'dump ranges to arrays
DataArray = DataRange
TargetArray = TargetRange
CriteriaArray = CriteriaRange

'reset k value and target array
k = 1
ReDim TargetArray(UBound(DataArray, 2), k)


'loop through list of lookup values and define LookupValue
 For h = 1 To UBound(CriteriaArray, 1)
    LookupValue = CriteriaRange(h, 1)

   'loop through data area comparing column 2 to LookupValue
     For i = 2 To UBound(DataArray, 1)
        If DataArray(i, 2) = LookupValue Then
        k = k + 1 'increment number of rows needed
        ReDim Preserve TargetArray(UBound(DataArray, 2), k) 'resize TargetArray to match

        'loop through each column of matching row and copy to TargetArray
         For j = 1 To UBound(DataArray, 2)
            TargetArray(k, j) = DataArray(i, j).Value

        Next j
        End If

     Next i
 Next h

'one all matching rows are added to TargetArray, copy back to worksheet table
TargetRange = TargetArray

'turn screen updating back on
Application.ScreenUpdating = True

End Sub

Answer 1

您的错误原因是数组没有值属性，因此TargetArray(k, j) = DataArray(i, j).Value应为TargetArray(k, j) = DataArray(i, j)

此外，还有几种提高代码性能的机会。请参阅内联评论

Sub CopyMatchingRows()
    Dim Data() As Variant, CriteriaArray() As Variant, TargetArray As Variant
    Dim DataRange As Range, CriteriaRange As Range, TargetRange As Range
 '   Dim rCountData As Integer, rCountCriteria As Integer, rCountTarget As Integer 'row counts
 '   Dim cCountData As Integer, cCountCriteria As Integer, cCountTarget As Integer 'col counts

    Dim LookupValue As Variant 'lookup value

    Dim h As Long, i As Long, j As Long, k As Long 'counters  <~~~ Use Longs

    'define ranges from tables
    Set DataRange = Worksheets("SourceData").ListObjects("DataTable").Range
    Set CriteriaRange = Worksheets("SchoolList").ListObjects("SchoolListTable").Range
    Set TargetRange = Worksheets("SchoolData").ListObjects("SchoolDataTable").DataBodyRange

    'turn screen updating back on
    Application.ScreenUpdating = False

    'clear target range contents
    'TargetRange.ClearContents

    '<~~~ dont need these
    'define row and column count variables
'    rCountData = DataRange.Rows.Count
'    rCountCriteria = CriteriaRange.Rows.Count
'    rCountTarget = TargetRange.Rows.Count
'    cCountData = DataRange.Columns.Count
'    cCountCriteria = CriteriaRange.Columns.Count
'    cCountTarget = TargetRange.Columns.Count

    '<~~~ dont need these
    'dimension arrays
'    ReDim DataArray(rCountData, cCountData)
'    ReDim CriteriaArray(rCountCriteria, cCountCriteria)


    'dump ranges to arrays  ~~~~ .Value is not necassary but adds clarity
    DataArray = DataRange.Value
    TargetArray = TargetRange.Value
    CriteriaArray = CriteriaRange.Value

    'reset k value and target array
    k = 1
    ReDim TargetArray(1 To UBound(DataArray, 2), 1 To UBound(CriteriaArray, 1) * UBound(DataArray, 1)) ' <~~~ max possible siz)


    'loop through list of lookup values and define LookupValue
     For h = 1 To UBound(CriteriaArray, 1)
        LookupValue = CriteriaRange(h, 1)

       'loop through data area comparing column 2 to LookupValue
         For i = 2 To UBound(DataArray, 1)
            If DataArray(i, 2) = LookupValue Then
                k = k + 1 'increment number of rows needed
                '<~~~ defer this
                'ReDim Preserve TargetArray(1 To UBound(DataArray, 2), k) 'resize TargetArray to match

                'loop through each column of matching row and copy to TargetArray
                For j = 1 To UBound(DataArray, 2)
                    TargetArray(k, j) = DataArray(i, j) '.Value
                Next j
            End If

         Next i
     Next h

    'once all matching rows are added to TargetArray, copy back to worksheet table
    ' <~~~ reduce to actual used size
    ReDim Preserve TargetArray(1 To UBound(TargetArray, 1), 1 To k)
    TargetRange = TargetArray

    'turn screen updating back on
    Application.ScreenUpdating = True
End Sub

Answer 2

您可以尝试使用AdvancedFilter方法，更轻松，更快捷。

Sub Match_Data()  

'' Declare Variables
Dim WksT as Worksheet

'' Set Variables
Set WksT = Worksheet("SchoolData")

'' First delete the previous table to avoid errors
Call DeleteTable(WksT,"SchoolDataTable")

'' Filter table
Range("SchoolListTable[#All]").AdvancedFilter _ '' Select Named Table
                        Action:=xlFilterCopy, _ '' How to filter
                        '' Select field to filter, in this case 
                        '' i'm assuming that the field name is "School"
                        CriteriaRange:=Range("DataTable[[#All],[School]]"), _  
                        CopyToRange:= WksT.Range("A1"), _ '' Where to put data
                        Unique:=False

'' Convert Range to named table 
WksT.ListObjects.Add(xlSrcRange,  _
                       WksT.Range("A1", WksT.Range("A1").End(xlToRight).End(xlDown)), , _  
                        xlYes).Name = "SchoolDataTable"

End Sub

删除表格

Private Sub DeleteTable(Wks As Worksheet, sName As String)
'' This is to avoid if the table not exists
On Error GoTo errHdlr
Dim oLObj As ListObject

Set oLObj = Wks.ListObjects(sName)
oLObj.Delete

Exit Sub
errHdlr:
    Resume Next
End Sub

如果您需要在Range使用Resize

中轻松删除数组

    '' Is "+ 1" if the array start at 0
    Range("A1").Resize(UBound(TargetArray) + 1, 1) = Application.Transpose(TargetArray)

可以在Excel VBA阵列之间直接复制单个值还是整行？

2 个答案: