Question

我已根据需要设置注释以运行和运行IBM Cognos公式。

为此，我将范围放入数组（LCogRng）。

我得到＆＃34;下标超出范围。＆＃34;一旦我到达ReDim Preserve LCogRng(1 To N, 1 To 2) As Range。

它没有Preserve，但是这就失败了。

Dim wb As Workbook
Dim ws As Worksheet
Dim rng As Range, N As Integer
Dim CogArr() As String
Dim LCogRng() As Range

Sub AddTM1()
Set wb = ActiveWorkbook
    For Each ws In wb.Worksheets
ReDim CogArr(1 To 1) As String
ReDim LCogRng(1 To 1, 1 To 2) As Range
    ws.Activate

    For Each rng In ws.UsedRange
            N = Mid(rng.Comment.Text, 3, InStr(rng.Comment.Text, ":") - 3)
            cFormula = Mid(rng.Comment.Text, 5 + N, Len(rng.Comment.Text))
            If CogArr(1) = "" Then
                CogArr(1) = cFormula
                Set LCogRng(1, 1) = rng
            ElseIf UBound(CogArr) < N Then
                ReDim Preserve CogArr(1 To N) As String
                ReDim Preserve LCogRng(1 To N, 1 To 2) As Range 'Error row
                CogArr(N) = cFormula
                Set LCogRng(N, 1) = rng
            End If
        ElseIf InStr(rng.Comment.Text, "TM") > 0 And Len(rng.Comment.Text) <= 6 Then
            N = Mid(rng.Comment.Text, 5, 2)
            Set LCogRng(N, 2) = rng
        End If
        End If
    Next rng

非常感谢任何帮助。

Answer 1

对于2D数组，您可以使用TRANSPOSE重新排序第一个尺寸，即：

Sub UpdateArray()
Dim X
'çreate 4*2 array
X = [{"Apple","2";"Bananna","3";"Don","Bradman";"#Fail","PUA"}]
MsgBox UBound(X, 1) & " " & UBound(X, 2)
ReDim Preserve X(1 To UBound(X, 1), 1 To UBound(X, 2) + 1)
X = Application.Transpose(X)
ReDim Preserve X(1 To UBound(X, 1), 1 To UBound(X, 2) + 1)
X = Application.Transpose(X)
'you now have a 5*3 array
MsgBox UBound(X, 1) & " " & UBound(X, 2)
End Sub

ReDim VBA中的多维数组

1 个答案: