Excel VBA数组之间可以直接复制单个值或整行？

我是新来的VBA和一般编程（和堆栈溢出）。 我有一个有三个工作表的工作簿。 我试图比较一张表中第一列的值与第二列的另一张大数据表中的值的列表。 如果他们匹配，我想复制该行到第三张表上的表格。 我没有使用数组（类似的循环，直接在表单/范围内工作），但是它的速度太慢了，尽pipe它通常能够成功完成，但是在这个过程中，它经常会让Excel陷入困境，所以我select了数组。

我设法得到源数据和查找值到数组中，我可以遍历数组，并检索任何单个单元格中的预期数据（我一直在使用中间窗口和debug.print来检查variables和数组的详细信息值）。

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

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

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

我可以将TargetArray中的每个值直接写回到目标工作表，但这看起来不比无数组方式快。

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

 TargetArray = DataArray 

我已经花了几天的时间，做了数百次search和大量的阅读来达到这一点，但我很难过。

1. 有没有什么诀窍可以让我从一个数组写入一个单独的值？
2. 如果没有，如何将行从一个表复制到另一个表，而不用几千次触摸工作表？ （又名“怎么会有人知道他们在做什么呢？”）

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

以下是所有的代码：

 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

因为你错误的原因是数组没有value属性，所以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 

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)