プログラミングのメモ

プログラミングの学び直し備忘録

VBA:Excel:配列とセル

aTEST_Array

Sub aTEST_Array()
    
  Dim arr()

'==================================
'/// 配列の配列を2次元配列で返す
'==================================
  Dim vArrOfArr(2)

  vArrOfArr(0) = Array("01", "02", "03", "04", "05")
  vArrOfArr(1) = Array("11", "12", "13", "14", "15")
  vArrOfArr(2) = Array("21", "22", "23", "24", "25")
'  vArrOfArr(3) = Array("21", "22", "23", "24")
  
    
  '// 配列の配列から2次元配列
  Dim vRes_Arr2d()
  vRes_Arr2d = getArrayOfArrayToArr(vArrOfArr)

  arr() = getArrConvArray2dTo1d(vRes_Arr2d)

'==================================
'/// クイックソート
'==================================
  arr() = Array(1, 51, 4, 8, 5, 45, 3, 8)
  
  Dim vResArr()
  vResArr = getArrSortQuick(arr(), LBound(arr), UBound(arr))

'==================================
'/// 重複削除
'==================================
  arr() = Array(1, 1, 1, 4, 8, 5, 4, 3)
  vResArr = getArrDelSameVal(arr())
  vResArr = getArrSortQuick(vResArr(), LBound(vResArr), UBound(vResArr))

'==================================
'// 配列かどうか/空かどうか確認
'==================================
  Dim lRes As Long
  
  '// 配列でない : -1
  Dim vNotArr
  lRes = getArrIsExists(vNotArr)
  
  '// 空の配列 : 0
  Dim vArr()
  lRes = getArrIsExists(vArr)
  
  '// 配列 : 1
  vArr = Array("a", 1)
  lRes = getArrIsExists(vArr)

'==================================
'* 配列の次元数を取得する
'==================================
  Debug.Print getArrDimension(vResArr)
  Debug.Print getArrDimension(vRes_Arr2d)
  Debug.Print getArrDimension(vArrOfArr)
    
'==================================
'* 配列の最大値取得
'==================================
  Debug.Print getArrMax(Array(3, 5, 1, 466, 7, 5, 333))
  
  vArrOfArr(0) = Array(3, 5, 7, 2, 4)
  vArrOfArr(1) = Array(43, 55, 67, 22, 14)
  vArrOfArr(2) = Array(3, 45, 7, 2, 4)
  Debug.Print getArrMax(vArrOfArr)
  
  vRes_Arr2d = getArrayOfArrayToArr(vArrOfArr)
  Debug.Print getArrMax(vRes_Arr2d)


End Sub

aTEST2_Array

'2次元配列で1行を配列で取得
'2次元配列で1列を配列で取得
Sub aTEST2_Array()

    Dim Array1D As Variant '一次元配列
'    Dim Array2D(1, 2) As Variant '二次元配列
    Dim Array2D(2, 2) As Variant '二次元配列
 
    If Call_arrDimensionCheck(Array2D) <> 2 Then Exit Sub
    
    Array2D(0, 0) = 1: Array2D(0, 1) = 2: Array2D(0, 2) = 3:
    Array2D(1, 0) = 11: Array2D(1, 1) = 12: Array2D(1, 2) = 13:
    Array2D(2, 0) = 1: Array2D(2, 1) = 2: Array2D(2, 2) = 3:
 
    
    Dim rsArr
    rsArr = getArrConv2dTo1dAtIndexNo(Array2D, "ROW", 1)
    rsArr = getArrConv2dTo1dAtIndexNo(Array2D, "ROW", 2)
    
    rsArr = getArrConv2dTo1dAtIndexNo(Array2D, "COL", 1)
    rsArr = getArrConv2dTo1dAtIndexNo(Array2D, "COL", 2)
    rsArr = getArrConv2dTo1dAtIndexNo(Array2D, "COL", 3)
    
    rsArr = getArrConv2dTo1dAtIndexNo(Array(1, 2, 3), "ROW", 1)
    rsArr = getArrConv2dTo1dAtIndexNo(Array(1, 2, 3), "COL", 3)
    
'%%%%%%%%%%%%%%%%%%%%%
    Dim ws As Worksheet: Set ws = ActiveSheet
    ws.Cells.ClearContents
  
    'Variant型動的配列の宣言
    Dim vArr() As Variant
    
    '配列の要素をシートのセルにセット
    vArr = Array(1, 2, 3, 4, 5)
    Dim rngStartCell As Range
    Set rngStartCell = ws.Range("A1")
    Call mth_SetCell1DArr(vArr, rngStartCell, "H")
    
'    vArr = Array(21, 22, 23, 24, 25)
'    Set rngStartCell = ws.Range("A2")
'    Call mth_SetCell1DArr(vArr, rngStartCell, "H")
    
    Dim myrange As Range
    Set myrange = rngStartCell.CurrentRegion
    myrange.Select
    
    vArr = myrange
    rsArr = getArrConv2dTo1dAtIndexNo(vArr, "COL", 3)
    rsArr = getArrConv2dTo1dAtIndexNo(vArr, "ROW", 1)
    
End Sub

aTEST_CellArray

Sub aTEST_CellArray()

    Dim vArr1D()
    vArr1D = Array(1, 3, 5, 4, 2)
    
    '// 出力
    ActiveSheet.Cells.ClearContents
    Call mth_SetCell1DArr(vArr1D, Range("B2"), "H")
    
    ActiveSheet.Cells.ClearContents
    Call mth_SetCell1DArr(vArr1D, Range("B2"), "V")
    

'///
    '// 出力データ生成
    Dim vArr(2, 5) As Variant
    
    Dim r As Long, c As Long
    For r = LBound(vArr, 1) To UBound(vArr, 1)
        For c = LBound(vArr, 2) To UBound(vArr, 2)
            vArr(r, c) = CStr(r) & CStr(c)
        Next c
    Next r
    
    '// 出力
    ActiveSheet.Cells.ClearContents
    Call setArr2dToRng(vArr, Range("B2"))

'///
  Dim vResArr
  vResArr = getRngToArr2d(Range("B2").CurrentRegion)

'=====================================================================
'/// 指定行範囲、指定列番号リストのセル値を配列の配列で返す
'=====================================================================
    '// 対象行範囲
    Dim lRowStartEnd(1) As Long
    lRowStartEnd(0) = 3: lRowStartEnd(1) = 8    '3:8行
    
    '// 抽出列
    Dim lColNos(3) As Long
    lColNos(0) = 2
    lColNos(1) = 3
    lColNos(2) = 5
    lColNos(3) = Columns("G").Column
    
    '// 配列の配列データ取得
    Dim vRes_ArrOfArr()
    vRes_ArrOfArr = mth_GetCellVal_ArrOfArr(ActiveSheet, lRowStartEnd, lColNos)

End Sub

aTest2

Sub aTest2()

  Dim r, c
  Dim arr As Variant
  
  arr = Range(Cells(1, 1), Cells(11, 5))
  
  For r = LBound(arr, 1) To UBound(arr, 1)
    For c = LBound(arr, 2) To UBound(arr, 2)
      arr(r, c) = StrConv(arr(r, c), vbUpperCase)
    Next c
  Next r
  
  Call mod_CellArr.setArr2dToRng(arr, Range("A1"))

End Sub

配列の配列 → 2次元配列

'*****************************************************************
'* 配列の配列 → 2次元配列
'*  配列の配列を2次元配列で返す(配列内の配列要素数は同じであること)
'*
'* ARG 01 : 配列の配列
'* ARG 02 : 出力開始セル
'* 戻り値 : 2次元配列
'*
'* 説明   : 配列内の配列は、1次元。
'*            先頭配列の要素数に合わせる
'*
'*****************************************************************
Public Function getArrayOfArrayToArr( _
                                        vArrayOfArray As Variant _
                                        ) As Variant
        
  Dim iColNum As Long
  iColNum = UBound(vArrayOfArray(LBound(vArrayOfArray)))
  
  Dim r As Long, c As Long
  
  
  '//
  Dim vRes_2dArr()
  
  ReDim vRes_2dArr(UBound(vArrayOfArray), iColNum)
  
  For r = LBound(vArrayOfArray) To UBound(vArrayOfArray)    '// 1段目配列(行)
    If UBound(vArrayOfArray(r)) <> iColNum Then
      getArrayOfArrayToArr = Array()
      Exit Function
    End If
    
    For c = LBound(vArrayOfArray(r)) To UBound(vArrayOfArray(r))  '// 2段目配列(列)
      vRes_2dArr(r, c) = vArrayOfArray(r)(c)
    Next
  Next
  
  getArrayOfArrayToArr = vRes_2dArr
    
End Function

クイックソート

'*****************************************************************
'* クイックソート
'*
'* ARG 01 : 対象配列
'* ARG 02 : LBound(対象配列)
'* ARG 03 : UBound(対象配列)
'* 戻り値 : 配列
'*
'* 説明   : 配列内の配列は、1次元。
'*            先頭配列の要素数に合わせる
'*
'*****************************************************************
Public Function getArrSortQuick( _
                                ByRef vargArr() As Variant, _
                                ByVal lngMin As Long, _
                                ByVal lngMax As Long _
                                ) As Variant()
    Dim i As Long, j As Long
    Dim vBase As Variant
    Dim vSwap As Variant
    
    vBase = vargArr(Int((lngMin + lngMax) / 2))
    i = lngMin
    j = lngMax
    
    Do
        Do While vargArr(i) < vBase
            i = i + 1
        Loop
        
        Do While vargArr(j) > vBase
            j = j - 1
        Loop
        
        If i >= j Then Exit Do
        
        vSwap = vargArr(i)
        vargArr(i) = vargArr(j)
        vargArr(j) = vSwap
        i = i + 1
        j = j - 1
    Loop
    
    If (lngMin < i - 1) Then
        Call getArrSortQuick(vargArr, lngMin, i - 1)
    End If
        
    If (lngMax > j + 1) Then
        Call getArrSortQuick(vargArr, j + 1, lngMax)
    End If

    getArrSortQuick = vargArr
    
End Function

重複削除

'*****************************************************************
'* 重複削除
'*
'* ARG 01 : 対象配列
'* ARG 02 : LBound(対象配列)
'* ARG 03 : UBound(対象配列)
'* 戻り値 : 配列
'*
'* 説明   : Dictionaryで配列要素をKey、Valを追加
'*           Key重複できないのでErrで追加不可
'*           Key(Val)値は、重複削除の値となる
'*
'*****************************************************************
Public Function getArrDelSameVal( _
                                vArrSrc() As Variant _
                                ) As Variant()
     
    Dim dic
    Dim i As Long
    
    Set dic = CreateObject("Scripting.Dictionary")

On Error Resume Next
    For i = 0 To UBound(vArrSrc)
        dic.Add vArrSrc(i), vArrSrc(i)
    Next
    
    getArrDelSameVal = dic.Keys
    
    Set dic = Nothing

End Function

配列判定

'*****************************************************************
'* 配列判定
'*  引数が配列かどうか判断し、配列の場合は空かどうか判断する
'*
'* ARG 01 : 対象配列
'* 戻り値 : 1:配列 / 0:空の配列 / -1:配列でない
'*
'*****************************************************************
Public Function getArrIsExists( _
                              vArr As Variant _
                              ) As Long

On Error GoTo ERR_PROC
    
    If IsArray(vArr) Then   '// 配列確認
        getArrIsExists = IIf(UBound(vArr) >= 0, 1, 0)
        ' 配列が空の場合、Ubound Err=9(インデックスが有効範囲にありません)
    Else
        getArrIsExists = -1  '配列でない
    End If
    
    Exit Function
        
ERR_PROC:
    If Err.Number = 9 Then  '// UBound(vArr)
        getArrIsExists = 0   '// vArr = Empty
    End If
    
End Function

配列の次元数

'*****************************************************************
'* 配列の次元数
'*
'* ARG 01 : 対象配列
'* 戻り値 :
'*
'*****************************************************************
Public Function getArrDimension( _
                                arr As Variant _
                                ) As Long
    
    Dim tmp As Variant
    Dim i As Long
     
    '■エラーが出るまでループ処理
    On Error Resume Next
    Do While Err.Number = 0
        i = i + 1
        tmp = UBound(arr, i)
    Loop
    On Error GoTo 0
     
    '■エラーが出た前の数(i-1)が渡された配列の次元数
    getArrDimension = i - 1
    
End Function

二次元配列 → 一次元配列

'*****************************************************************
'* 二次元配列 → 一次元配列
'*  2次元配列から一次元配列に移行する
'*
'* ARG 01 : 対象2次配列
'* 戻り値 :
'*
'*****************************************************************
Public Function getArrConvArray2dTo1d( _
                                      Array2D _
                                      ) As Variant()
    
    Dim v
    Dim i As Long
    Dim r As Long, c As Long
    
    Dim Array1D() As Variant '一次元配列
    For r = LBound(Array2D, 1) To UBound(Array2D, 1)
      For c = LBound(Array2D, 2) To UBound(Array2D, 2)
        ReDim Preserve Array1D(i)
        Array1D(i) = Array2D(r, c)
        i = i + 1
      Next c
    Next r

    getArrConvArray2dTo1d = IIf(IsArray(Array1D), Array1D, Array(Array1D))
    
End Function

二次元配列 → 指定行or列 の 一次元配列

'*****************************************************************
'* 二次元配列 → 指定行or列 の 一次元配列
'*  二次元配列から特定行or列を一次元配列に移行する
'*
'* ARG 01 : 対象2次元配列
'* ARG 02 : 行or列 [ROW]or[COL]
'* ARG 03 : 指定行or列番号
'* 戻り値 :
'*
'*****************************************************************
Public Function getArrConv2dTo1dAtIndexNo( _
                                      Array2D, _
                                      ByVal sRowOrCol As String, _
                                      ByVal iSelRowOrColNo As Long _
                                      ) As Variant()
    Dim i As Long
    Dim Array1D As Variant '一次元配列
'    Dim Array2D As Variant '二次元配列
 
'    Array2D = Range("A1:B1")
'    Array2D = rngTrg
 
    Select Case sRowOrCol
    Case "ROW"
        Select Case getArrDimension(Array2D)
        Case 2
            '■二次元配列の指定行(2行目)を一次元配列に格納する
            Array1D = WorksheetFunction.Index(Array2D, iSelRowOrColNo)
        Case 1
            Array1D = Array2D
        Case Else
            Stop
        End Select
    
    Case "COL"
       '■二次元配列の指定列(A列(1列目))を一次元配列に格納する
       '(行列反転して対象行を取得)※縦一列だとうまくいかない。
        Select Case getArrDimension(Array2D)
        Case 2, 1
            Array1D = WorksheetFunction.Index(WorksheetFunction.Transpose(Array2D), iSelRowOrColNo)
        Case Else
            Stop
        End Select
    
    Case Else
        Stop
    
    End Select
    
    getArrConv2dTo1dAtIndexNo = IIf(IsArray(Array1D), Array1D, Array(Array1D))
    
End Function

多次元配列 → 一次元配列

'*****************************************************************
'* 多次元配列 → 一次元配列
'*  多次元配列から一次元配列に移行する
'*
'* ARG 01 : 対象配列
'* 戻り値 :
'*
'*****************************************************************
Public Function getArrConvMultiDimToSingleDim( _
                                      arr _
                                      ) As Variant()
    
    Dim v
    Dim i As Long
    
    Dim Array1D() As Variant '一次元配列
    For Each v In arr
      ReDim Preserve Array1D(i)
      Array1D(i) = v
      i = i + 1
      
    Next v

    getArrConvArray2dTo1d = IIf(IsArray(Array1D), Array1D, Array(Array1D))
    
End Function

配列の最大値

'*****************************************************************
'* 配列の最大値
'*
'* ARG 01 : 対象配列(1次元,2次元,配列の配列) ※ジャグ配列はNG
'* 戻り値 :
'*
'*****************************************************************
Public Function getArrMax( _
                        vArr As Variant _
                        )
                        
  getArrMax = WorksheetFunction.Max(vArr)
  
End Function

一次元配列 → セル

'*****************************************************************
'* 一次元配列 → セル
'*  配列1D(one dimension)をセルに出力
'*
'* ARG01 : 対象データ
'* ARG02 : 出力開始セル
'* ARG03 : 出力方向 [H]Horizon, [V]Vertical
'*
'* 戻り値
'*
'*****************************************************************
Public Sub setArr1dToRng( _
                                vArr() As Variant, _
                                ByVal rngStartCell As Range, _
                                ByVal direction As String _
                                )

    '=======================
    '//
    '=======================
    Dim lRowMax As Long:
    Dim lColMax As Long:
    
    Select Case direction
    Case "H"
        lRowMax = 1
        lColMax = UBound(vArr, 1) - LBound(vArr, 1) + 1
        
        '※出力サイズの設定が必要
        rngStartCell.Resize(lRowMax, lColMax).Value = vArr
    
    Case "V"
        lRowMax = UBound(vArr, 1) - LBound(vArr, 1) + 1
        lColMax = 1
        
        '※出力サイズの設定が必要
        rngStartCell.Resize(lRowMax, lColMax).Value = WorksheetFunction.Transpose(vArr)
    
    End Select
    
End Sub

二次元配列 → セル

'*****************************************************************
'* 二次元配列 → セル
'*  配列2D(two dimension)をセルに出力
'*
'* ARG01 : 対象データ
'* ARG02 : 出力開始セル
'*
'* 戻り値
'*
'*****************************************************************
Public Sub setArr2dToRng( _
                                vArr As Variant, _
                                rngStartCell As Range _
                                )

    '=======================
    '//
    '=======================
    Dim lRowMax As Long:    lRowMax = UBound(vArr, 1) - LBound(vArr, 1) + 1
    Dim lColMax As Long:    lColMax = UBound(vArr, 2) - LBound(vArr, 2) + 1
    
    '※出力サイズの設定が必要
    rngStartCell.Resize(lRowMax, lColMax).Value = vArr
    
End Sub

セル範囲 → 二次元配列

'*****************************************************************
'* セル範囲 → 二次元配列
'*  セル範囲の値を2次元配列で取得
'*
'* ARG01 : 対象データ
'* ARG02 : 出力開始セル
'*
'* 戻り値 :
'*
'*****************************************************************
Public Function getRngToArr2d( _
                                  ByVal rng As Range _
                                  ) As Variant()

    '=======================
    '// セルの値を要素に代入
    '=======================
    Dim vArrCell As Variant
    vArrCell = rng.Value    '※indexは「1」から
    
    getRngToArr2d = vArrCell
    
End Function

セル行範囲、指定列 → 配列の配列

'*****************************************************************
'* セル行範囲、指定列 → 配列の配列
'*  指定行範囲、指定列番号リストのセル値を配列の配列で返す
'*
'* ARG 01 : WorkSheet
'* ARG 02 : 行範囲配列(開始:終了)
'* ARG 03 : 対象列番号
'*
'* 戻り値 : 配列の配列
'*
'*****************************************************************
Public Function getRngRowsAndColListsToArrOfArr( _
                                            ws As Worksheet, _
                                            lRowStartEnd() As Long, _
                                            lColNos() As Long _
                                            ) As Variant
  Dim vResDat() As Variant
  
  Dim lRow As Long
  
  Dim i As Long: i = 0
  For lRow = lRowStartEnd(LBound(lRowStartEnd)) To lRowStartEnd(UBound(lRowStartEnd))
    ReDim Preserve vResDat(i)
    
    '// 列データ
    Dim sBuf()
    ReDim sBuf(UBound(lColNos))
            
    Dim j As Long: j = 0
    Dim vCol As Variant
    For Each vCol In lColNos
        sBuf(j) = ws.Cells(lRow, vCol).Value
        j = j + 1
    Next
    
    vResDat(i) = sBuf
    i = i + 1
  Next
  
  getRngRowsAndColListsToArrOfArr = vResDat
        
End Function

二次元文字列配列 → 半角・大文字

'*****************************************************************
'* 二次元文字列配列 → 半角・大文字
'*
'* ARG 01 : 対象配列
'* 戻り値 :
'*
'*****************************************************************
Public Function getArr2dConvNarrowUpper( _
                                      arr2D _
                                      ) As Variant
              
  Dim resArr2D
  ReDim resArr2D(LBound(arr2D, 1) To UBound(arr2D, 1), LBound(arr2D, 2) To UBound(arr2D, 2))
  
  Dim r, c
  
  Dim sBuf As String
  
  For r = LBound(arr2D, 1) To UBound(arr2D, 1)
    For c = LBound(arr2D, 2) To UBound(arr2D, 2)
      sBuf = StrConv(arr2D(r, c), vbNarrow)
      sBuf = StrConv(sBuf, vbUpperCase)
      resArr2D(r, c) = sBuf
    Next c
  Next r
  
  getArr2dConvNarrowUpper = resArr2D
  
End Function