VBA Excel二维数组

Question

我试图找出如何声明一个二维数组,但到目前为止我找到的所有例子都是用set整数声明的.我正在尝试创建一个程序,它将利用两个2维数组,然后对这些数组执行简单的操作(例如查找差异或百分比).数组由Excel工作表中的数字填充(一组数字在Sheet1上,另一组在Sheet2上,两组具有相同的行数和列数).

由于我不知道有多少行或列,我将使用变量.

Dim s1excel As Worksheet
Dim s2excel As Worksheet
Dim s3excel As Worksheet
Dim firstSheetName As String
Dim secondSheetName As String
Dim totalRow As Integer
Dim totalCol As Integer
Dim iRow As Integer
Dim iCol As Integer

Set s1excel = ThisWorkbook.ActiveSheet

' Open the "Raw_Data" workbook
Set wbs = Workbooks.Open(file_path & data_title)
wbs.Activate
ActiveWorkbook.Sheets(firstSheetName).Select
Set s2excel = wbs.ActiveSheet

' Find totalRow, totalColumn (assumes there's values in Column A and Row 1 with no blanks)
totalRow = ActiveSheet.Range("A1").End(xlDown).Row
totalCol = ActiveSheet.Range("A1").End(xlToRight).Column

Dim s2Array(totalRow, totalCol)
Dim s3Array(totalRow, totalCol)

For iRow = 1 To totalRow
    For iCol = 1 To totalCol
        s2Array(iRow, iCol) = Cells(iRow, iCol)
    Next iCol
Next iRow

ActiveWorkbook.Sheets(secondSheetName).Select
Set s3excel = wbs.ActiveSheet

For iRow = 1 To totalRow
    For iCol = 1 To totalCol
        s3Array(iRow, iCol) = Cells(iRow, iCol)
    Next iCol
Next iRow

当我尝试运行它时,我在"Dim s2Array(totalRow,totalCol)"中得到编译时错误,表示需要一个常量表达式.如果我将其更改为"Dim s2Array(1 To totalRow,1 To totalCol)",则会出现相同的错误.由于我不知道尺寸是什么,我不能声明它像"Dim s2Array(1,1)"因为那样我会得到一个越界异常.

谢谢,

杰西斯莫瑟蒙

Answer 1

实际上我不会使用任何REDIM,也不会使用循环将数据从工作表传输到数组:

dim arOne()
arOne = range("A2:F1000")

甚至

arOne = range("A2").CurrentRegion

就是这样,你的数组填充得更快,然后循环,没有redim.

Answer 2

你需要ReDim:

m = 5
n = 8
Dim my_array()
ReDim my_array(1 To m, 1 To n)
For i = 1 To m
  For j = 1 To n
    my_array(i, j) = i * j
  Next
Next

For i = 1 To m
  For j = 1 To n
    Cells(i, j) = my_array(i, j)
  Next
Next

正如其他人所指出的那样,使用范围可以更好地解决实际问题.你可以尝试这样的事情:

Dim r1 As Range
Dim r2 As Range
Dim ws1 As Worksheet
Dim ws2 As Worksheet

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
totalRow = ws1.Range("A1").End(xlDown).Row
totalCol = ws1.Range("A1").End(xlToRight).Column

Set r1 = ws1.Range(ws1.Cells(1, 1), ws1.Cells(totalRow, totalCol))
Set r2 = ws2.Range(ws2.Cells(1, 1), ws2.Cells(totalRow, totalCol))
r2.Value = r1.Value

Answer 3

这是一个通用的VBA阵列到范围功能,它将一个数组写入工作表,只需一次"命中"到工作表.这比在行和列的循环中一次一个单元格中将数据写入工作表要快得多......但是,要做一些内务处理,因为必须正确指定目标范围的大小.

这种"内务处理"看起来很多工作,而且可能相当慢:但这是写入工作表的"最后一英里"代码,而且一切都比写入工作表更快.或者至少,与读取或写入工作表相比,即使在VBA中也是如此之快,以至于它实际上是即时的,并且在您点击工作表之前,您应该尽可能地在代码中执行所有操作.

其中一个主要组成部分是错误捕获,我曾经看到过它随处可见.我讨厌重复编码:我在这里编写了所有代码,并且 - 希望 - 你永远不必再写它了.

VBA'阵列到范围'功能

Public Sub ArrayToRange(rngTarget As Excel.Range, InputArray As Variant)
' Write an array to an Excel range in a single 'hit' to the sheet
' InputArray must be a 2-Dimensional structure of the form Variant(Rows, Columns)

' The target range is resized automatically to the dimensions of the array, with
' the top left cell used as the start point.

' This subroutine saves repetitive coding for a common VBA and Excel task.

' If you think you won't need the code that works around common errors (long strings
' and objects in the array, etc) then feel free to comment them out.

On Error Resume Next

'
' Author: Nigel Heffernan
' HTTP://Excellerando.blogspot.com
'
' This code is in te public domain: take care to mark it clearly, and segregate
' it from proprietary code if you intend to assert intellectual property rights
' or impose commercial confidentiality restrictions on that proprietary code

Dim rngOutput As Excel.Range

Dim iRowCount   As Long
Dim iColCount   As Long
Dim iRow        As Long
Dim iCol        As Long
Dim arrTemp     As Variant
Dim iDimensions As Integer

Dim iRowOffset  As Long
Dim iColOffset  As Long
Dim iStart      As Long


Application.EnableEvents = False
If rngTarget.Cells.Count > 1 Then
    rngTarget.ClearContents
End If
Application.EnableEvents = True

If IsEmpty(InputArray) Then
    Exit Sub
End If


If TypeName(InputArray) = "Range" Then
    InputArray = InputArray.Value
End If

' Is it actually an array? IsArray is sadly broken so...
If Not InStr(TypeName(InputArray), "(") Then
    rngTarget.Cells(1, 1).Value2 = InputArray
    Exit Sub
End If


iDimensions = ArrayDimensions(InputArray)

If iDimensions < 1 Then

    rngTarget.Value = CStr(InputArray)

ElseIf iDimensions = 1 Then

    iRowCount = UBound(InputArray) - LBound(InputArray)
    iStart = LBound(InputArray)
    iColCount = 1

    If iRowCount > (655354 - rngTarget.Row) Then
        iRowCount = 655354 + iStart - rngTarget.Row
        ReDim Preserve InputArray(iStart To iRowCount)
    End If

    iRowCount = UBound(InputArray) - LBound(InputArray)
    iColCount = 1

    ' It's a vector. Yes, I asked for a 2-Dimensional array. But I'm feeling generous.
    ' By convention, a vector is presented in Excel as an arry of 1 to n rows and 1 column.
    ReDim arrTemp(LBound(InputArray, 1) To UBound(InputArray, 1), 1 To 1)
    For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
        arrTemp(iRow, 1) = InputArray(iRow)
    Next

    With rngTarget.Worksheet
        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount))
        rngOutput.Value2 = arrTemp
        Set rngTarget = rngOutput
    End With

    Erase arrTemp

ElseIf iDimensions = 2 Then

    iRowCount = UBound(InputArray, 1) - LBound(InputArray, 1)
    iColCount = UBound(InputArray, 2) - LBound(InputArray, 2)

    iStart = LBound(InputArray, 1)

    If iRowCount > (65534 - rngTarget.Row) Then
        iRowCount = 65534 - rngTarget.Row
        InputArray = ArrayTranspose(InputArray)
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iRowCount)
        InputArray = ArrayTranspose(InputArray)
    End If


    iStart = LBound(InputArray, 2)
    If iColCount > (254 - rngTarget.Column) Then
        ReDim Preserve InputArray(LBound(InputArray, 1) To UBound(InputArray, 1), iStart To iColCount)
    End If



    With rngTarget.Worksheet

        Set rngOutput = .Range(rngTarget.Cells(1, 1), rngTarget.Cells(iRowCount + 1, iColCount + 1))

        Err.Clear
        Application.EnableEvents = False
        rngOutput.Value2 = InputArray
        Application.EnableEvents = True

        If Err.Number <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        InputArray(iRow, iCol) = Trim(InputArray(iRow, iCol))
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Formula = InputArray
        End If 'err<>0

        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)
                    If IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        If Left(InputArray(iRow, iCol), 1) = "=" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "+" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                        If Left(InputArray(iRow, iCol), 1) = "*" Then
                            InputArray(iRow, iCol) = "'" & InputArray(iRow, iCol)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Value2 = InputArray
        End If 'err<>0

        If Err <> 0 Then
            For iRow = LBound(InputArray, 1) To UBound(InputArray, 1)
                For iCol = LBound(InputArray, 2) To UBound(InputArray, 2)

                    If IsObject(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = "[OBJECT] " & TypeName(InputArray(iRow, iCol))
                    ElseIf IsArray(InputArray(iRow, iCol)) Then
                        InputArray(iRow, iCol) = Split(InputArray(iRow, iCol), ",")
                    ElseIf IsNumeric(InputArray(iRow, iCol)) Then
                        ' no action
                    Else
                        InputArray(iRow, iCol) = "" & InputArray(iRow, iCol)
                        If Len(InputArray(iRow, iCol)) > 255 Then
                            ' Block-write operations fail on strings exceeding 255 chars. You *have*
                            ' to go back and check, and write this masterpiece one cell at a time...
                            InputArray(iRow, iCol) = Left(Trim(InputArray(iRow, iCol)), 255)
                        End If
                    End If
                Next iCol
            Next iRow
            Err.Clear
            rngOutput.Text = InputArray
        End If 'err<>0

        If Err <> 0 Then
            Application.ScreenUpdating = False
            Application.Calculation = xlCalculationManual
            iRowOffset = LBound(InputArray, 1) - 1
            iColOffset = LBound(InputArray, 2) - 1
            For iRow = 1 To iRowCount
                If iRow Mod 100 = 0 Then
                    Application.StatusBar = "Filling range... " & CInt(100# * iRow / iRowCount) & "%"
                End If
                For iCol = 1 To iColCount
                    rngOutput.Cells(iRow, iCol) = InputArray(iRow + iRowOffset, iCol + iColOffset)
                Next iCol
            Next iRow
            Application.StatusBar = False
            Application.ScreenUpdating = True


        End If 'err<>0


        Set rngTarget = rngOutput   ' resizes the range This is useful, *most* of the time

    End With

End If

End Sub

您需要ArrayDimensions的源代码:

模块头中需要此API声明:

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                   (Destination As Any, _
                    Source As Any, _
                    ByVal Length As Long)

......这是功能本身:

Private Function ArrayDimensions(arr As Variant) As Integer
  '-----------------------------------------------------------------
  ' will return:
  ' -1 if not an array
  ' 0  if an un-dimmed array
  ' 1  or more indicating the number of dimensions of a dimmed array
  '-----------------------------------------------------------------


  ' Retrieved from Chris Rae's VBA Code Archive - http://chrisrae.com/vba
  ' Code written by Chris Rae, 25/5/00

  ' Originally published by R. B. Smissaert.
  ' Additional credits to Bob Phillips, Rick Rothstein, and Thomas Eyde on VB2TheMax

  Dim ptr As Long
  Dim vType As Integer

  Const VT_BYREF = &H4000&

  'get the real VarType of the argument
  'this is similar to VarType(), but returns also the VT_BYREF bit
  CopyMemory vType, arr, 2

  'exit if not an array
  If (vType And vbArray) = 0 Then
    ArrayDimensions = -1
    Exit Function
  End If

  'get the address of the SAFEARRAY descriptor
  'this is stored in the second half of the
  'Variant parameter that has received the array
  CopyMemory ptr, ByVal VarPtr(arr) + 8, 4

  'see whether the routine was passed a Variant
  'that contains an array, rather than directly an array
  'in the former case ptr already points to the SA structure.
  'Thanks to Monte Hansen for this fix

  If (vType And VT_BYREF) Then
    ' ptr is a pointer to a pointer
    CopyMemory ptr, ByVal ptr, 4
  End If

  'get the address of the SAFEARRAY structure
  'this is stored in the descriptor

  'get the first word of the SAFEARRAY structure
  'which holds the number of dimensions
  '...but first check that saAddr is non-zero, otherwise
  'this routine bombs when the array is uninitialized

  If ptr Then
    CopyMemory ArrayDimensions, ByVal ptr, 2
  End If

End Function

另外:我建议你保持声明私密.如果必须在另一个模块Option Private Module中将其设为public Sub,请在模块头中插入该语句.您真的不希望您的用户使用CopyMemoryoperations和指针算法调用任何函数.