可以单独值或整个行会的Excel VBA阵列之间直接复制？ [英] Can individual values or entire rows be copied directly between Excel VBA arrays?

问题描述

我是新来的VBA和一般（和堆栈溢出）节目。我有三个工作表的工作簿。我试图在一个表的第1列上的一个片与另一个大的数据表的第2列进行比较的值的列​​表。如果它们匹配，我想到该行复制到表上的第三片材。我有这个工作，而不阵列（类似于循环，对张的工作/直接范围），但它是太缓慢，但它通常能顺利完成，往往带来的Excel其在过程中的膝盖，让我去阵列。

我设法源数据和查找值到数组，我可以通过数组循环，并检索到任何个体细胞中的预期数据（我一直在使用中间窗口，debug.print检查变量和细节有关阵列值）。

我只是想不通的最后几件。对于每一个匹配的行我想每个单元从数据阵列目标阵列复制。当目标数组填充我想它转储到一个表上的第三个工作表。

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

  TargetArray（K，J）= DataArray中（I，J）.value的
 

我可以在TargetArray每个值直接写回目标表，但这似乎并不比无阵列的方式更快。

一旦我能做到这一点，我要做到这一点，我相信这将工作：

  TargetArray = DataArray中
 

我花了几天就这个问题和做阅读拿到了这一点数以百计的搜索和大量的，但我很为难。

1. 是否有西港岛线让我一个人写值从一个阵列到另一个地方的把戏？


2. 如果没有，怎么能行从一个表到另一个不接触的工作表上千倍复制？ （又名怎么会有人谁知道他们在做什么办法吗？）

毫无疑问，我的code已经不必要的步骤等问题。所有的建议都是AP preciated。

下面是所有code的：

 显式的选项
选项​​基本1
子CopyMatchingRows（）
昏暗DataArray中（）为Variant，Crit​​eriaArray（）作为变，TargetArray为Variant
昏暗DataRange作为范围，Crit​​eriaRange作为范围，TargetRange作为范围
昏暗rCountData整数，rCountCriteria整数，rCountTarget作为整数的行数
昏暗cCountData整数，cCountCriteria整数，cCountTarget作为整数关口计数昏暗LookupValue为Variant查找值昏暗事项h作为整数，我作为整数，J为整数，K作为整数'柜从定义范围内的表
设置DataRange =工作表（SourceData）。ListObjects（数据表）。范围
设置CriteriaRange =工作表（SchoolList）。ListObjects（SchoolListTable）。范围
设置TargetRange =工作表（SchoolData）。ListObjects（SchoolDataTable）。DataBodyRange打开屏幕更新回
Application.ScreenUpdating =假清晰的目标范围的内容
TargetRange.ClearContents定义的行和列数变量
rCountData = DataRange.Rows.Count
rCountCriteria = CriteriaRange.Rows.Count
rCountTarget = TargetRange.Rows.Count
cCountData = DataRange.Columns.Count
cCountCriteria = CriteriaRange.Columns.Count
cCountTarget = TargetRange.Columns.Count维数组
使用ReDim DataArray中（rCountData，cCountData）
使用ReDim CriteriaArray（rCountCriteria，cCountCriteria）
转储范围为数组
DataArray中= DataRange
TargetArray = TargetRange
CriteriaArray = CriteriaRange重置K值和目标阵列
K = 1
使用ReDim TargetArray（UBound函数（DataArray中，2），k）的
'遍历查找值列表，并定义LookupValue
 对于H = 1要UBound函数（CriteriaArray，1）
    LookupValue = CriteriaRange（H，1）   遍历数据区比较列2至LookupValue
     对于i = 2到UBound函数（DataArray中，1）
        如果DataArray中（I，2）= LookupValue然后
        K = K + 1'增量所需行数
        使用ReDim preserve TargetArray（UBound函数（DataArray中，2），k）的调整TargetArray匹配        遍历匹配的行和每一列复制到TargetArray
         对于j = 1向UBound函数（DataArray中，2）
            TargetArray（K，J）= DataArray中（I，J）。价值        下面j
        万一     接下来，我
 轰下一所有匹配的行添加到TargetArray，复制回工作单表
TargetRange = TargetArray打开屏幕更新回
Application.ScreenUpdating = TRUE结束小组
 

解决方案

你的错误的原因是数组没有值属性，因此 TargetArray（K，J）= DataArray中（I， j）条.value的应 TargetArray（K，J）= DataArray中（I，J）

此外，还有一个数opertunities提高code的性能。见行内注释

 子CopyMatchingRows（）
    昏暗数据（）为Variant，Crit​​eriaArray（）作为变，TargetArray为Variant
    昏暗DataRange作为范围，Crit​​eriaRange作为范围，TargetRange作为范围
 昏暗rCountData整数，rCountCriteria整数，rCountTarget作为整数的行数
 昏暗cCountData整数，cCountCriteria整数，cCountTarget作为整数关口计数    昏暗LookupValue为Variant查找值    昏暗事项h作为长，我只要，J长，K只要'柜台＆LT; ~~~使用多头    从定义范围内的表
    设置DataRange =工作表（SourceData）。ListObjects（数据表）。范围
    设置CriteriaRange =工作表（SchoolList）。ListObjects（SchoolListTable）。范围
    设置TargetRange =工作表（SchoolData）。ListObjects（SchoolDataTable）。DataBodyRange    打开屏幕更新回
    Application.ScreenUpdating =假    清晰的目标范围的内容
    TargetRange.ClearContents    '＆LT; ~~~不需要这些
    定义的行和列数变量
rCountData = DataRange.Rows.Count
rCountCriteria = CriteriaRange.Rows.Count
rCountTarget = TargetRange.Rows.Count
cCountData = DataRange.Columns.Count
cCountCriteria = CriteriaRange.Columns.Count
cCountTarget = TargetRange.Columns.Count    '＆LT; ~~~不需要这些
    维数组
使用ReDim DataArray中（rCountData，cCountData）
使用ReDim CriteriaArray（rCountCriteria，cCountCriteria）
    转储范围为阵列~~~~ .value的不是necassary，但增加了清晰度
    DataArray中= DataRange.Value
    TargetArray = TargetRange.Value
    CriteriaArray = CriteriaRange.Value    重置K值和目标阵列
    K = 1
    使用ReDim TargetArray（1向UBound函数（DataArray中，2），1向UBound函数（CriteriaArray，1）* UBound函数（DataArray中，1））'＆下; ~~~最大可能SIZ）
    '遍历查找值列表，并定义LookupValue
     对于H = 1要UBound函数（CriteriaArray，1）
        LookupValue = CriteriaRange（H，1）       遍历数据区比较列2至LookupValue
         对于i = 2到UBound函数（DataArray中，1）
            如果DataArray中（I，2）= LookupValue然后
                K = K + 1'增量所需行数
                '＆LT; ~~~这推迟
                '使用ReDim preserve TargetArray（1向UBound函数（DataArray中，2），k）的调整TargetArray匹配                遍历匹配的行和每一列复制到TargetArray
                对于j = 1向UBound函数（DataArray中，2）
                    TargetArray（K，J）= DataArray中（I，J）。价值
                下面j
            万一         接下来，我
     轰下    一旦所有匹配的行添加到TargetArray，复制回工作表
    '＆LT; ~~~降低实际使用的大小
    使用ReDim preserve TargetArray（1向UBound函数（TargetArray，1），1至K）
    TargetRange = TargetArray    打开屏幕更新回
    Application.ScreenUpdating = TRUE
结束小组
 

I'm new to VBA and programming in general (and stack overflow). I have a workbook with three worksheets. I'm trying to compare a list of values in column 1 of a table on one sheet with column 2 of a large data table on another. If they match, I want to copy that row to a table on a third sheet. I had this working without arrays (similar loops, working on sheets/ranges directly), but it was way too slow and, though it usually completed successfully, it often brought Excel to its knees in the process, so I went to arrays.

I managed to get the source data and lookup values into arrays, and I can loop through the arrays and retrieved the expected data in any individual cell (I've been using the intermediate window and debug.print to check variables and details about the array values).

I just can't figure out the last few pieces. For each matching row I'm trying to copy each cell from the data array to the target array. When the target array is populated I want to dump it into a table on a third worksheet.

I'm getting a runtime 424 object required error here:

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

I could write each value in the TargetArray directly back to the target sheet, but this seems no faster than the no-array way.

Once I can do that I was going to do this, which I believe will work:

TargetArray = DataArray 

I have spent days on this and done hundreds of searches and lots of reading to get to this point, but I'm stumped.

1. Is there any trick that wil allow me to write an individual value from one array to another?
2. If not, how can rows be copied from one table to another without touching the worksheet thousands of times? (aka "how would someone who knows what they're doing approach this?")

No doubt my code has unneeded steps and other issues. All suggestions are appreciated.

Here's all of the code:

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

解决方案

Cause of your error is that arrays don't have a value property, so TargetArray(k, j) = DataArray(i, j).Value should be TargetArray(k, j) = DataArray(i, j)

Also, there a several opertunities to improve performance of the code. See inline comments

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

这篇关于可以单独值或整个行会的Excel VBA阵列之间直接复制？的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！