[TOP][基本操作] [関数] [お遊び] [マクロを登録][ユーザー定義表示形式][自作メニュー]



<2、関数編>

付属の関数が、もうちょっと使い勝手が悪くて、思い通りの返り値を出せない。よく使われそうな、あって良さそうな関数が見あたらない。そういうことってありますよね。いっそ、作ってしまいましょう。
(動作確認環境=Windows98,Excel97&2000)

mailto:マイニー・ヨシツネ
2006/4/29 更新


<<お気に入りのマクロをコピーして、エクセルのVBAモジュールにペーストしてください。あとは「関数の貼り付け」ウィザードから、または他のプロシージャーから呼び出してご利用ください。>>


VBAコード編集を助けます
GetFormula_Right'式の右辺だけを取り出します

GetFormula_Left'式の左辺だけを取り出します

ChangeFormula_RightToLeft'式の左辺と右辺を入れ替えます

CombineStrings'セル文字列を結合
'使い方のサンプルをcodeaid.xls(43KB)にしました。参考にしてください。
'圧縮したものはcodeaid.lzh(13KB)です。

Area3Angle_3sd'3辺の長さから3角形の面積を求めます

Area3Angle_xy'3頂点のXY座標から3角形の面積を求めます

Area5gon_xy'五角形の面積をxy座標から求めます

AreaPolygon_xyarray'多角形(3角形を含む)の面積を頂点のxy座標から求めます

FChooseFrom_a_CSVDataRange'1つのセルのCSVデータを各セルに展開します。

FNumberOfSheets'ワークシートの数を返します。

FGetDoubleValFromString 文字列の中の数字を集めて小数を返します

FGetLongValFromString 文字列の中の数字を集めて整数を返します

FGetCsvData 選択範囲のセルの値をコンマ区切りのCSVデータ形式にまとめます


Function GetFormula_Right(selrange As Range) As String戻る
    '式の右辺だけを取り出します
    'マクロコード作成に便利です
    '式(=)がないと「= is not」を返します
    Dim n%, cellstring$
    
    cellstring$ = selrange.Formula
    If Len(cellstring) = 0 Then GoTo isnotequal
    n = InStr(cellstring, "=")
    
    If n = 0 Then GoTo isnotequal
    GetFormula_Right = Right(cellstring, Len(cellstring) - n)
    Exit Function
isnotequal:
    GetFormula_Right = "= is not"
End Function



Function GetFormula_Left(selrange As Range) As String戻る
    '式の左辺だけを取り出します
    'マクロコード作成に便利です
    '式(=)がないと「= is not」を返します
    Dim n%, cellstring$
    
    cellstring = selrange.Formula
    If Len(cellstring) = 0 Then GoTo isnotequal
    n = InStr(cellstring, "=")
    
    If n = 0 Then GoTo isnotequal
    GetFormula_Left = Left(cellstring, n - 1)
    Exit Function
isnotequal:
    GetFormula_Left = "= is not"
End Function



Function ChangeFormula_RightToLeft(selrange As Range) As String戻る
    '式の左辺右辺を入れ替えます
    'マクロコード作成に便利です
    '式(=)がないと「= is not」を返します
    Dim n%, cellstring$
    
    cellstring = selrange.Formula
    If Len(cellstring) = 0 Then GoTo isnotequal
    n = InStr(cellstring, "=")
    
    If n = 0 Then GoTo isnotequal
    ChangeFormula_RightToLeft = Right(cellstring, Len(cellstring) - n) _
        & "=" & Left(cellstring, n - 1)
    Exit Function
isnotequal:
ChangeFormula_RightToLeft = "= is not"
End Function



Function CombineStrings(selrange As Range) As String 'セル文字列を結合戻る
    '選択範囲のすべての文字列を結合します
    Dim a As Range
    
    CombineStrings = ""
    For Each a In selrange
        CombineStrings = CombineStrings & a.Formula
    Next a
End Function



Function Area3Angle_3sd(a, b, C) As Variant戻る
'三角形の面積
'3辺の長さから3角形の面積を求めます
    Dim s
    'ヘロンの公式により
    s = (a + b + C) / 2
    Area3Angle_3sd = Sqr(s * (s - a) * (s - b) * (s - C))
End Function



Function Area3Angle_xy(x1, x2, x3, y1, y2, y3) As Variant戻る
'三角形の面積
'3頂点のXY座標から3角形の面積を求めます
    Area3Angle_xy = (x1 * (y3 - y2) + x2 * (y1 - y3) + x3 * (y2 - y1)) / 2
End Function



Function Area5gon_xy(x1, x2, x3, x4, x5, y1, y2, y3, y4, y5) As Variant戻る
'五角形の面積xy座標から求めます
'3角形が3つ合わさったものが5角形
    Area5gon_xy = Area3Angle_xy(x1, x2, x3, y1, y2, y3) + _
                Area3Angle_xy(x1, x3, x4, y1, y3, y4) + _
                Area3Angle_xy(x1, x4, x5, y1, y4, y5)
End Function



Function AreaPolygon_xyarray(xyarray) As Variant戻る
'多角形の面積を求めます
'n角形(3角形を含む)の面積を頂点のxy座標の2元配列から求めます
'xy座標が入っているセル範囲、または配列を引数にすることができます
'縦横どちらでも対応します
'xyの順にこだわりません
'頂点は時計回りでも、その逆でもかまいません
'Area3Angle_xyを使って計算しますので、注意してください
'精度が増すように Variant にしました
    Dim al, au, bl, bu, array_size, xs(), ys(), n, xy
    If IsObject(xyarray) Then
    'セル範囲の場合は、その値を配列に入れる
        xy = xyarray.Formula
    ElseIf IsArray(xyarray) Then
    '配列の場合はそのまま
        xy = xyarray
    Else
        AreaPolygon_xyarray = "エラー!(配列ではありません)"
        Exit Function
    End If
    
    On Error Resume Next
    '2元配列かどうか調べる
    al = LBound(xy)
    au = UBound(xy)
    bl = LBound(xy, 2)
    bu = UBound(xy, 2)
    If Err.Number > 0 Then
        AreaPolygon_xyarray = "エラー!(適切な配列ではありません)"
        Exit Function
    End If
    If Not (((au - al) = 1) Or ((bu - bl) = 1)) Then
        AreaPolygon_xyarray = "エラー!(2元配列ではありません)"
        Exit Function
    End If
    
    If (au - al) = 1 Then '縦配列
        array_size = bu - bl
        ReDim xs(array_size)
        ReDim ys(array_size)
        For n = 0 To bu - bl 'xs,ys配列に置き換え
            xs(n) = Val(xyarray(al, bl + n))
            ys(n) = Val(xyarray(au, bl + n))
        Next n
    Else '横配列
        array_size = au - al
        ReDim xs(array_size)
        ReDim ys(array_size)
        For n = 0 To au - al 'xs,ys配列に置き換え
            xs(n) = Val(xyarray(al + n, bl))
            ys(n) = Val(xyarray(al + n, bu))
        Next n
    End If
    
    AreaPolygon_xyarray = 0
    For n = 0 To array_size - 2
    '3角形が(n-2)合わさったものがn角形
        AreaPolygon_xyarray = AreaPolygon_xyarray + _
            Area3Angle_xy(xs(0), xs(n + 1), xs(n + 2), ys(0), ys(n + 1), ys(n + 2))
    Next n
    
End Function



Function FChooseFrom_a_CSVDataRange(objRange As Range, intIndex As Integer) As Double戻る
'intIndexは連続データの入ったセルの値を(例えばB$1形式で)参照するようにしたら楽です。
'FGetCsvDatの逆です。例えばA列にCSVデータが複数入り、第1行にB列から1.2...と値を入れたとします。
'するとB2のセルは「=Personal.xls!FChooseFrom_a_CSVDataRange($A2,B$1)」
'のようになりますか。これを右へフィル、下へフィルするとCSVデータが各セルに展開されます。
    Dim n%, m%, strCharacter$, strItem$
    m = 0
    strItem = ""
    For n = 1 To Len(objRange.Formula)
    strCharacter = Mid(objRange.Formula, n, 1)
    If strCharacter = "," Then 'カンマ区切りのデータです
        m = m + 1
        If m = intIndex Then
            FChooseFrom_a_CSVDataRange = Val(strItem)
            Exit Function
        End If
        strItem = ""
    Else
        strItem = strItem + strCharacter
    End If
    
    Next n
    m = m + 1
    If intIndex = m Then
        FChooseFrom_a_CSVDataRange = Val(strItem)
    Else
        FChooseFrom_a_CSVDataRange = 0 'データがないと0を返します
    End If
End Function



Function FNumberOfSheets() As Integer戻る
'ワークシートの数を返します。シート数が多いときに使えますね。
    FNumberOfSheets = ActiveWorkbook.Worksheets.Count
    'ワークシートを挿入したとき、自動再計算してくれないのが難点。
    'いずれかのセルを編集し直したり(ダブルクリック、enter)、値を入れると再計算します。(少し不便)
End Function



Function FGetDoubleValFromString(文字 As String) As Double戻る
'文字列の中の数字を集めて小数を返します
    Dim strCur$, n%, intStrLen%, intCurChr%, strResult$
    Dim counter%
    
    strResult = ""
    counter = 0
    intStrLen = Len(文字)
    
    For n = 1 To intStrLen
        strCur = Mid(文字, n, 1)
        intCurChr = AscW(strCur)
        Select Case intCurChr
            Case 46 '.
                'そのまま
                counter = counter + 1
            Case 48 To 57 '半角数字
                'そのまま
                counter = counter + 1
            Case -240 To -231 '全角数字
                strCur = ChrW(intCurChr + 288)
                counter = counter + 1
            Case 45 '- 頭にだけつける
                If counter > 0 Then strCur = ""
            Case Else '数字以外
                strCur = ""
            
        End Select
        strResult = strResult & strCur
    Next n
    FGetDoubleValFromString = Val(strResult)
End Function



Function FGetLongValFromString(文字 As String) As Long戻る
'文字列の中の数字を集めて整数を返します
    Dim strCur$, n%, intStrLen%, intCurChr%, strResult$
    Dim counter%
    strResult = ""
    counter = 0
    intStrLen = Len(文字)
    
    For n = 1 To intStrLen
        strCur = Mid(文字, n, 1)
        intCurChr = AscW(strCur)
        Select Case intCurChr
            Case 48 To 57 '半角数字
                'そのまま
                counter = counter + 1
            Case -240 To -231 '全角数字
                strCur = ChrW(intCurChr + 288)
                counter = counter + 1
            Case 45 '- 最初だけつける
                If counter > 0 Then strCur = ""
            Case Else '数字以外
                strCur = ""
            
        End Select
        strResult = strResult & strCur
    Next n
    FGetLongValFromString = Val(strResult)
End Function



Function FGetCsvData(選択範囲 As Range) As String戻る
'選択範囲のセルの値をコンマ区切りのCSVデータ形式にまとめます
    Dim singlecell As Range
    Dim strResult$
    
    strResult = ""
    For Each singlecell In 選択範囲
        strResult = strResult & singlecell.Value
        strResult = strResult & ","
    Next
    strResult = Left(strResult, Len(strResult) - 1)
    FGetCsvData = strResult
End Function



Excel VBA トップページへ戻る