[已解决][求助]二维数组的赋值

Dj_soo

QUOTE:

以下是引用蓝桥玄霜在2009-11-6 14:40:00的发言：
Sub test()
Dim arr1
Dim arr2, n&, i&
arr1 = Sheet1.[A1:H12]
For i = 1 To UBound(arr1)
    If Cells(i, 1).Interior.ColorIndex = 6 Then
        n = n + 1
        Cells(n, 11).Resize(1, 8) = Application.Index(arr1, i, 0)
    End If
Next
arr2 = Cells(1, 11).Resize(n, 8)
Cells(1, 11).Resize(n, 8).ClearContents
End Sub

你好蓝版,你的代码用了辅助,但是如果数据量很大的话,对单元格太多的操作会使代码的速度很慢,我也就是因为这样才想要纯数组的操作.

如果只针对Arr1来操作,是否可以达到效果呢?

黄色区域的行标假定我们是已经知道的.可以选择其中三行来避免太多的枚举.

[此贴子已经被作者于2009-11-6 14:47:17编辑过]

安贤

Sub 数组()
Dim arr1, arr2
Dim x, y, m
y = 1
arr1 = Range("A1:H12")
ReDim arr2(UBound(arr1, 1), UBound(arr1, 2))
For x = 1 To Range("A65536").End(xlUp).Row Step 2
    For m = 0 To UBound(arr2, 2) - 1
        arr2(y, m) = arr1(x, m + 1)
    Next m
    y = y + 1
Next x
[I15].Resize(UBound(arr2, 1), UBound(arr2, 2)) = arr2
End Sub

搁浅2008

没办法 好像数组只能取到值 得不到颜色  要通过Interior.ColorIndex

搁浅2008

aScscPLz.rar (9.67 KB, 下载次数: 3)

2009-11-6 15:14 上传

点击文件名下载附件
[求助]二维数组的赋值

搁浅2008

Sub test()
    Dim arr1
    Dim arr2()
    Dim i As Long
    Dim j As Long
    Dim n As Long
    n = 1
    arr1 = Sheet1.Range("A1:H12").Value
    For i = 1 To UBound(arr1, 1)
        If Sheet1.Cells(i, 1).Interior.ColorIndex = 6 Then
            ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To n)
            For j = 1 To UBound(arr1, 2)
                arr2(j, n) = arr1(i, j)
            Next j
            n = n + 1
        End If
    Next i
  Sheet1.Range("J1").Resize(n - 1, UBound(arr1, 2)) = Application.Transpose(arr2)

End Sub

Dj_soo

QUOTE:

以下是引用搁浅2008在2009-11-6 15:15:00的发言：

Sub test()
    Dim arr1
    Dim arr2()
    Dim i As Long
    Dim j As Long
    Dim n As Long
    n = 1
    arr1 = Sheet1.Range("A1:H12").Value
    For i = 1 To UBound(arr1, 1)
        If Sheet1.Cells(i, 1).Interior.ColorIndex = 6 Then
            ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To n)
            For j = 1 To UBound(arr1, 2)
                arr2(j, n) = arr1(i, j)
            Next j
            n = n + 1
        End If
    Next i
  Sheet1.Range("J1").Resize(n - 1, UBound(arr1, 2)) = Application.Transpose(arr2)

End Sub

刚开会去了,想了一下,实在没有捷径,还是老老实实的用循环.

我想到两种方式,一种是每次循环都像你这样n=n+1来Redim Preserve一次,

另一种是直接定义和原来一样容量的,最后赋值完毕后再循环一次找到临界点后只一次Redim Preserve.

安贤的就是第二种思路,不过后面没有处理上界问题.我再看看先.

不过如果能不用循环的最好了,嘿嘿,暂时不设最佳,等过两天真没有不用循环的方式我再设置了

[em04]