[VBA] エラー発生を考慮したプロパティ取得関数

エラー発生を考慮したプロパティの取得

Public Function GetPropertySafely(Target As Object, Properties As String, Optional ReturnValueOnError)

    On Error GoTo ERROR_LINE

    Dim Retval, Names, Name As String, TmpObj As Object, i As Long
    Set TmpObj = Target
    Names = Split(Properties, ".")

    For i = LBound(Names) To UBound(Names) - 1 Step 1
        Name = Names(i)
        Set TmpObj = CallByName(TmpObj, Name, VbGet)
    Next

    Name = Names(UBound(Names))
    Retval = CallByName(TmpObj, Name, VbGet)

ERROR_LINE:

    If Err.Number <> 0 Then
        If IsMissing(ReturnValueOnError) Then
            Retval = "[ERR-" & Err.Number & "]" & Err.Description & "プロパティ: " & Name
        Else
            Retval = ReturnValueOnError
        End If
    End If

    GetPropertySafely = Retval

End Function

[Excel VBA] Rangeオブジェクトの2次元配列の作成

指定のセル範囲の各Rangeオブジェクトを２次元配列に格納

Public Function CreateRangeArray( _
        TargetRange As Range, _
        RangeArray() As Range, _
        Optional BaseIndex As Long = 0 _
    )

    If Not TypeOf TargetRange Is Range Then
        CreateRangeArray = 1
        Exit Function
    End If

    If BaseIndex < 0 Then
        CreateRangeArray = 2
        Exit Function
    End If

    Dim RowList As Object, ColList As Object
    Set RowList = CreateObject("System.Collections.SortedList")
    Set ColList = CreateObject("System.Collections.SortedList")

    Dim Cell As Range
    For Each Cell In TargetRange.Cells
        If Not RowList.ContainsKey(Cell.Row) Then
            Call RowList.Add(Cell.Row, 0)
        End If
        If Not ColList.ContainsKey(Cell.Column) Then
            Call ColList.Add(Cell.Column, 0)
        End If
    Next

    ReDim RangeArray( _
            0 + BaseIndex To RowList.Count - 1 + BaseIndex, _
            0 + BaseIndex To ColList.Count - 1 + BaseIndex _
        ) As Range

    Dim r As Long, c As Long
    For Each Cell In TargetRange.Cells
        r = RowList.IndexOfKey(Cell.Row)
        c = ColList.IndexOfKey(Cell.Column)
        Set RangeArray(r + BaseIndex, c + BaseIndex) = Cell
    Next

    CreateRangeArray = 0

End Function

[VBA] タブを空白に変換する関数

文字列内に含まれるタブを空白に変換する（ファンクション版）

Public Function TabToSpace(TabString As String, Optional TabSize As Long = 4) As String

    Dim CurrPos As Long, PrevPos As Long, FindPos As Long
    Dim SpcSize As Long, SubStr As String, Result As String

    CurrPos = 0
    PrevPos = 0
    FindPos = InStr(PrevPos + 1, TabString, vbTab)

    Do While FindPos > 0
        SubStr = Mid(TabString, PrevPos + 1, FindPos - PrevPos - 1)
        Result = Result & SubStr
        CurrPos = CurrPos + LenB(StrConv(SubStr, vbFromUnicode))
        
        SpcSize = TabSize - (CurrPos Mod TabSize)
        Result = Result & Space(SpcSize)
        CurrPos = CurrPos + SpcSize
        
        PrevPos = FindPos
        FindPos = InStr(PrevPos + 1, TabString, vbTab)
    Loop

    If PrevPos = 0 Then
        TabToSpace = TabString
    Else
        TabToSpace = Result & Mid(TabString, PrevPos + 1)
    End If

End Function

文字列内に含まれるタブを空白に変換する（プロシージャ版）

Public Sub Tab2Space(TabString As String, Optional TabSize As Long = 4)

    Dim CurrPos As Long, PrevPos As Long, FindPos As Long
    Dim SpcSize As Long, SubStr As String, Result As String

    CurrPos = 0
    PrevPos = 0
    FindPos = InStr(PrevPos + 1, TabString, vbTab)

    Do While FindPos > 0
        SubStr = Mid(TabString, PrevPos + 1, FindPos - PrevPos - 1)
        Result = Result & SubStr
        CurrPos = CurrPos + LenB(StrConv(SubStr, vbFromUnicode))
        
        SpcSize = TabSize - (CurrPos Mod TabSize)
        Result = Result & Space(SpcSize)
        CurrPos = CurrPos + SpcSize
        
        PrevPos = FindPos
        FindPos = InStr(PrevPos + 1, TabString, vbTab)
    Loop

    If PrevPos <> 0 Then
        TabString = Result & Mid(TabString, PrevPos + 1)
    End If

End Sub

[Excel VBA] 選択範囲の正規化（？）

複数のセル範囲を正規化します。

Public Function NormalizeRange(Ranges As Range) As Range

    Dim Retval As Range
    Dim i As Long

    If Not Ranges Is Nothing Then
        Set Retval = Ranges.Areas(1)
        For i = 2 To Ranges.Areas.Count Step 1
            Set Retval = Application.Union(Retval, Ranges.Areas(i))
        Next
    End If

    Set NormalizeRange = Retval

End Function