VBA 2次元配列の1次元目の要素数を変更

Transpose関数を利用

Option Base 1
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
'★2次元配列の1次元目の要素数を増やす (Transpose利用)
'*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-
Public Function zfRedimPreserveArray(ByVal arr As Variant, ByVal rowNum As Long)
    Dim tempArr() As Variant
     
    tempArr = WorksheetFunction.Transpose(arr)
    ReDim Preserve tempArr(UBound(tempArr, 1), rowNum)
     
    zfRedimPreserveArray = WorksheetFunction.Transpose(tempArr)
End Function

Public Function zfRedimPreserveArray2(ByVal arr As Variant, ByVal rowNum As Long)
    Dim tempArr() As Variant
    Dim i As Long
    If rowNum = 1 Then
        ReDim tempArr(1, UBound(arr, 2))
        For i = 1 To UBound(arr, 2)
            tempArr(1, i) = arr(1, i)
        Next i
        zfRedimPreserveArray = tempArr
    Else
        tempArr = WorksheetFunction.Transpose(arr)
        ReDim Preserve tempArr(UBound(tempArr, 1), rowNum)
         
        zfRedimPreserveArray = WorksheetFunction.Transpose(tempArr)
    End If
End Function

一時保管用配列を利用

===============================================================
' 任意の行数で配列を縮小 (手動ループ)
'===============================================================
Public Function zfRedimPreserveArray2(ByVal arr As Variant, ByVal newRowCount As Long) As Variant
    Dim tempArr() As Variant
    Dim i As Long, j As Long
    Dim maxRow As Long, maxCol As Long

    maxRow = UBound(arr, 1)
    maxCol = UBound(arr, 2)

    If newRowCount < 1 Or newRowCount > maxRow Then
        Err.Raise vbObjectError + 1, , "指定した行数が不正です"
    End If

    ReDim tempArr(1 To newRowCount, 1 To maxCol)

    For i = 1 To newRowCount
        For j = 1 To maxCol
            tempArr(i, j) = arr(i, j)
        Next j
    Next i

    zfRedimPreserveArray2 = tempArr
End Function

Transpose関数と手動ループの違い

方法安全性高速性実用性
Transpose を使う×(65536超NG)
手動ループで縮小◎(大量データOK)

コメント