excel vba custom functions

otherFuncs.bas

' 参照設定 Microsoft VBScript Regular Expressions
' 参照設定 Microsoft Scripting Runtime
Function Variation(myRng As Range) As Long
' 引数内の範囲に何種類のデータが有るかカウント
    
    '連想配列を利用
    Dim myDict As New Scripting.Dictionary
    Dim cl As Variant
    For Each cl In myRng.Cells
        If cl.Value <> "" And myDict.Exists(cl.Value) = False Then
            myDict.Add cl.Value, 1
        End If
    Next
    Variation = myDict.Count
    
End Function

Function Zen2Han(myStr As String) As String
'全角英数を半角に変換する
    Dim myReg As New RegExp
    With myReg
        
        .IgnoreCase = False '大文字と小文字を区別する
        .Global = True '文字列全体を検索する
        
        '左から順に全角大文字アルファベット，全角小文字アルファベット，全角数字
        .Pattern = "[\uFF21-\uFF3A]|[\uFF41-\uFF5A]|[\uFF10-\uFF19]"
        
        Set Matches = .Execute(myStr)
        
        'マッチしたすべての文字列を置換
        For Each Match In Matches
            myStr = Replace(myStr, Match.Value, StrConv(Match.Value, vbNarrow))
        Next Match
        
    End With
    
    Zen2Han = myStr
End Function

Function WLOOKUP(myStr As Variant, myRng As Range) As String
' 簡易版VLOOKUP
    On Error Resume Next
    
    WLOOKUP = Application.WorksheetFunction. _
        VLookup(myStr, myRng, myRng.Columns.Count, False) & ""
    
    If Err Then WLOOKUP = "【NoHit】"
    
End Function

Function Bars2Hyphen(tgt As Variant) As String
' ハイフン系を統一
' http://qiita.com/ryounagaoka/items/4cf5191d1a2763667add
' http://www.wordvbalab.com/code/3178/

'正規表現
Dim myReg As New RegExp
With myReg
    .Pattern = "\u002D|[\u2010-\u2014]|\u2043|\u2212|\uFF70" ' パターンを設定
    .IgnoreCase = False ' 大文字と小文字を区別する
    .Global = True ' 文字列全体を検索する
    Bars2Hyphen = .Replace(tgt, "-")
End With

End Function

Function CHAIN(myRange As Range, delim As Variant) As String
' 文字列結合関数
    Dim rng As Range
    Dim ret As String: ret = ""

    For Each rng In myRange
        ret = ret & rng.Text & delim
    Next
    
    If delim = "" Then
        CHAIN = ret
        Exit Function
    End If
    
    '正規表現
    Dim myReg As New RegExp
    With myReg
        .IgnoreCase = False ' 大文字と小文字を区別する
        .Global = True ' 文字列全体を検索する
        
        ' 連続する区切り文字を削除
        .Pattern = delim & "{2,}"
        CHAIN = .Replace(ret, delim)
        
        '先頭と末尾の区切り文字を削除
        .Pattern = delim & "$|^" & delim
        CHAIN = .Replace(CHAIN, "")
    End With

End Function

Function RexMATCH(myTarget As Range, searchWord As String) As Long
' 正規表現マッチ
    '正規表現
    Dim myReg As New RegExp
    With myReg
        .Pattern = searchWord ' パターンを設定
        .IgnoreCase = False ' 大文字と小文字を区別する
        .Global = True ' 文字列全体を検索する
        RexMATCH = .Execute(myTarget.Text).Count
    End With
    
End Function

Function RexREPLACE(myTarget As Range, WordToRep As String, RepdWord As String) As String
' 正規表現置換
    '正規表現
    Dim myReg As New RegExp
    With myReg
        .Pattern = WordToRep ' パターンを設定
        .IgnoreCase = False ' 大文字と小文字を区別する
        .Global = True ' 文字列全体を検索する
        RexREPLACE = .Replace(myTarget.Text, RepdWord)
    End With
    
End Function

Function RexDELETE(myTarget As Range, WordToRep As String) As String
' 正規表現削除
    '正規表現
    Dim myReg As New RegExp
    With myReg
        .Pattern = WordToRep ' パターンを設定
        .IgnoreCase = False ' 大文字と小文字を区別する
        .Global = True ' 文字列全体を検索する
        RexDELETE = .Replace(myTarget.Text, "")
    End With
    
End Function

Function Jusho(tgt As Variant, lv As Variant) As String
' 住所文字列を都道府県／市区郡／それ以降に区切る
    '正規表現
    Dim myReg As New RegExp
    With myReg
        .IgnoreCase = False ' 大文字と小文字を区別する
        .Global = True ' 文字列全体を検索する
        .Pattern = "(.{2,3}?[都道府県])(.+?[市区郡])(.+)" ' パターンを設定
        If lv = 1 Then
            Jusho = .Replace(tgt, "$1")
        ElseIf lv = 2 Then
            Jusho = .Replace(tgt, "$2")
        ElseIf lv = 3 Then
            Jusho = .Replace(tgt, "$3")
        End If
    End With
    
End Function

rubyFuncs.bas

'参照設定 Microsoft VBScript Regular Expressions
Function GETRUBY(tgt As Variant, Optional mode = 0) As String

    Dim flag As String
    If mode = 0 Then
        flag = vbHiragana
    ElseIf mode = 1 Then
        flag = vbKatakana
    End If

    Dim tx1 As String
    tx1 = StrConv(Application.GetPhonetic(tgt), flag)

    '特定の役物を削除
    Dim myReg As New RegExp
    With myReg
        .IgnoreCase = False ' 大文字と小文字を区別する
        .Global = True ' 文字列全体を検索する
        .Pattern = "([・，。、－-])|([ 　]{2,})" ' 句読点と連続する空白
        GETRUBY = .Replace(tx1, "") 'ヒットした部分を置換
    End With

End Function

Function ROMA2KANA(wd As Variant) As Variant

    wd = Replace(wd, "A", "えい", , , vbTextCompare)
    wd = Replace(wd, "B", "びー", , , vbTextCompare)
    wd = Replace(wd, "C", "しー", , , vbTextCompare)
    wd = Replace(wd, "D", "でぃー", , , vbTextCompare)
    wd = Replace(wd, "E", "いー", , , vbTextCompare)
    wd = Replace(wd, "F", "えふ", , , vbTextCompare)
    wd = Replace(wd, "G", "じー", , , vbTextCompare)
    wd = Replace(wd, "H", "えいち", , , vbTextCompare)
    wd = Replace(wd, "I", "あい", , , vbTextCompare)
    wd = Replace(wd, "J", "じぇい", , , vbTextCompare)
    wd = Replace(wd, "K", "けい", , , vbTextCompare)
    wd = Replace(wd, "L", "える", , , vbTextCompare)
    wd = Replace(wd, "M", "えむ", , , vbTextCompare)
    wd = Replace(wd, "N", "えぬ", , , vbTextCompare)
    wd = Replace(wd, "O", "おー", , , vbTextCompare)
    wd = Replace(wd, "P", "ぴー", , , vbTextCompare)
    wd = Replace(wd, "Q", "きゅー", , , vbTextCompare)
    wd = Replace(wd, "R", "あーる", , , vbTextCompare)
    wd = Replace(wd, "S", "えす", , , vbTextCompare)
    wd = Replace(wd, "T", "てぃー", , , vbTextCompare)
    wd = Replace(wd, "U", "ゆー", , , vbTextCompare)
    wd = Replace(wd, "V", "ぶい", , , vbTextCompare)
    wd = Replace(wd, "W", "だぶりゅー", , , vbTextCompare)
    wd = Replace(wd, "X", "えっくす", , , vbTextCompare)
    wd = Replace(wd, "Y", "わい", , , vbTextCompare)
    wd = Replace(wd, "Z", "ぜっと", , , vbTextCompare)
        
    ROMA2KANA = wd
End Function


Function SAKUYOMI(wd As Variant) As Variant
    wd = StrConv(wd, vbHiragana)
    wd = Replace(wd, "ぁ", "あ", , , vbTextCompare)
    wd = Replace(wd, "ぃ", "い", , , vbTextCompare)
    wd = Replace(wd, "ぅ", "う", , , vbTextCompare)
    wd = Replace(wd, "ぇ", "え", , , vbTextCompare)
    wd = Replace(wd, "ぉ", "お", , , vbTextCompare)
    wd = Replace(wd, "ヴ", "う", , , vbTextCompare)
    wd = Replace(wd, "が", "か", , , vbTextCompare)
    wd = Replace(wd, "ぎ", "き", , , vbTextCompare)
    wd = Replace(wd, "ぐ", "く", , , vbTextCompare)
    wd = Replace(wd, "げ", "け", , , vbTextCompare)
    wd = Replace(wd, "ご", "こ", , , vbTextCompare)
    wd = Replace(wd, "ざ", "さ", , , vbTextCompare)
    wd = Replace(wd, "じ", "し", , , vbTextCompare)
    wd = Replace(wd, "ず", "す", , , vbTextCompare)
    wd = Replace(wd, "ぜ", "せ", , , vbTextCompare)
    wd = Replace(wd, "ぞ", "そ", , , vbTextCompare)
    wd = Replace(wd, "だ", "た", , , vbTextCompare)
    wd = Replace(wd, "ぢ", "ち", , , vbTextCompare)
    wd = Replace(wd, "づ", "つ", , , vbTextCompare)
    wd = Replace(wd, "っ", "つ", , , vbTextCompare)
    wd = Replace(wd, "で", "て", , , vbTextCompare)
    wd = Replace(wd, "ど", "と", , , vbTextCompare)
    wd = Replace(wd, "ば", "は", , , vbTextCompare)
    wd = Replace(wd, "び", "ひ", , , vbTextCompare)
    wd = Replace(wd, "ぶ", "ふ", , , vbTextCompare)
    wd = Replace(wd, "べ", "へ", , , vbTextCompare)
    wd = Replace(wd, "ぼ", "ほ", , , vbTextCompare)
    wd = Replace(wd, "ぱ", "は", , , vbTextCompare)
    wd = Replace(wd, "ぴ", "ひ", , , vbTextCompare)
    wd = Replace(wd, "ぷ", "ふ", , , vbTextCompare)
    wd = Replace(wd, "ぺ", "へ", , , vbTextCompare)
    wd = Replace(wd, "ぽ", "ほ", , , vbTextCompare)
    wd = Replace(wd, "ゃ", "や", , , vbTextCompare)
    wd = Replace(wd, "ゅ", "ゆ", , , vbTextCompare)
    wd = Replace(wd, "ょ", "よ", , , vbTextCompare)
    wd = Replace(wd, "ー", "", , , vbTextCompare)

    ' 一部を除いて役物を削除
'    Dim myReg As New RegExp
'    With myReg
'        .IgnoreCase = False ' 大文字と小文字を区別する
'        .Global = True ' 文字列全体を検索する
'        .Pattern = "[^ぁ-んA-Z[]／/]" ' パターンを設定（[^]内はエスケープ不要）
'        SAKUYOMI = .Replace(wd, "") ' 上記パターン以外を削除
'    End With
    SAKUYOMI = wd
End Function


Function KANA2ROMA(wd As String) As String
    
    wd = Replace(wd, "あ", "A", , , vbTextCompare)
    wd = Replace(wd, "い", "I", , , vbTextCompare)
    wd = Replace(wd, "う", "U", , , vbTextCompare)
    wd = Replace(wd, "え", "E", , , vbTextCompare)
    wd = Replace(wd, "お", "O", , , vbTextCompare)
    wd = Replace(wd, "か", "Ka", , , vbTextCompare)
    wd = Replace(wd, "き", "Ki", , , vbTextCompare)
    wd = Replace(wd, "く", "Ku", , , vbTextCompare)
    wd = Replace(wd, "け", "Ke", , , vbTextCompare)
    wd = Replace(wd, "こ", "Ko", , , vbTextCompare)
    wd = Replace(wd, "さ", "Sa", , , vbTextCompare)
    wd = Replace(wd, "し", "Shi", , , vbTextCompare)
    wd = Replace(wd, "す", "Su", , , vbTextCompare)
    wd = Replace(wd, "せ", "Se", , , vbTextCompare)
    wd = Replace(wd, "そ", "So", , , vbTextCompare)
    wd = Replace(wd, "た", "Ta", , , vbTextCompare)
    wd = Replace(wd, "ち", "Chi", , , vbTextCompare)
    wd = Replace(wd, "つ", "Tsu", , , vbTextCompare)
    wd = Replace(wd, "て", "Te", , , vbTextCompare)
    wd = Replace(wd, "と", "To", , , vbTextCompare)
    wd = Replace(wd, "な", "Na", , , vbTextCompare)
    wd = Replace(wd, "に", "Ni", , , vbTextCompare)
    wd = Replace(wd, "ぬ", "Nu", , , vbTextCompare)
    wd = Replace(wd, "ね", "Ne", , , vbTextCompare)
    wd = Replace(wd, "の", "No", , , vbTextCompare)
    wd = Replace(wd, "は", "Ha", , , vbTextCompare)
    wd = Replace(wd, "ひ", "Hi", , , vbTextCompare)
    wd = Replace(wd, "ふ", "Fu", , , vbTextCompare)
    wd = Replace(wd, "へ", "He", , , vbTextCompare)
    wd = Replace(wd, "ほ", "Ho", , , vbTextCompare)
    wd = Replace(wd, "ま", "Ma", , , vbTextCompare)
    wd = Replace(wd, "み", "Mi", , , vbTextCompare)
    wd = Replace(wd, "む", "Mu", , , vbTextCompare)
    wd = Replace(wd, "め", "Me", , , vbTextCompare)
    wd = Replace(wd, "も", "Mo", , , vbTextCompare)
    wd = Replace(wd, "や", "Ya", , , vbTextCompare)
    wd = Replace(wd, "ゆ", "Yu", , , vbTextCompare)
    wd = Replace(wd, "よ", "Yo", , , vbTextCompare)
    wd = Replace(wd, "ら", "Ra", , , vbTextCompare)
    wd = Replace(wd, "り", "Ri", , , vbTextCompare)
    wd = Replace(wd, "る", "Ru", , , vbTextCompare)
    wd = Replace(wd, "れ", "Re", , , vbTextCompare)
    wd = Replace(wd, "ろ", "Ro", , , vbTextCompare)
    wd = Replace(wd, "わ", "Wa", , , vbTextCompare)
    wd = Replace(wd, "を", "Wo", , , vbTextCompare)
    wd = Replace(wd, "ん", "N", , , vbTextCompare)
    wd = Replace(wd, "が", "Ga", , , vbTextCompare)
    wd = Replace(wd, "ぎ", "Gi", , , vbTextCompare)
    wd = Replace(wd, "ぐ", "Gu", , , vbTextCompare)
    wd = Replace(wd, "げ", "Ge", , , vbTextCompare)
    wd = Replace(wd, "ご", "Go", , , vbTextCompare)
    wd = Replace(wd, "ざ", "Za", , , vbTextCompare)
    wd = Replace(wd, "じ", "Ji", , , vbTextCompare)
    wd = Replace(wd, "ず", "Zu", , , vbTextCompare)
    wd = Replace(wd, "ぜ", "Ze", , , vbTextCompare)
    wd = Replace(wd, "ぞ", "Zo", , , vbTextCompare)
    wd = Replace(wd, "だ", "Da", , , vbTextCompare)
    wd = Replace(wd, "ぢ", "Di", , , vbTextCompare)
    wd = Replace(wd, "づ", "Zu", , , vbTextCompare)
    wd = Replace(wd, "で", "De", , , vbTextCompare)
    wd = Replace(wd, "ど", "Do", , , vbTextCompare)
    wd = Replace(wd, "ば", "Ba", , , vbTextCompare)
    wd = Replace(wd, "び", "Bi", , , vbTextCompare)
    wd = Replace(wd, "ぶ", "Bu", , , vbTextCompare)
    wd = Replace(wd, "べ", "Be", , , vbTextCompare)
    wd = Replace(wd, "ぼ", "Bo", , , vbTextCompare)
    wd = Replace(wd, "ぱ", "Pa", , , vbTextCompare)
    wd = Replace(wd, "ぴ", "Pi", , , vbTextCompare)
    wd = Replace(wd, "ぷ", "Pu", , , vbTextCompare)
    wd = Replace(wd, "ぺ", "Pe", , , vbTextCompare)
    wd = Replace(wd, "ぽ", "Po", , , vbTextCompare)
    wd = Replace(wd, "ゃ", "Lya", , , vbTextCompare)
    wd = Replace(wd, "ゅ", "Lyu", , , vbTextCompare)
    wd = Replace(wd, "ょ", "Lyo", , , vbTextCompare)
    wd = Replace(wd, "っ", "Ltu", , , vbTextCompare)
    
    Dim myReg As New RegExp
    With myReg
        .IgnoreCase = False ' 大文字と小文字を区別する
        .Global = True ' 文字列全体を検索する
        
        '拗音処理（サ行タ行）
        .Pattern = "([CS]h|J)iLy(.)" ' パターンを設定
        wd = .Replace(wd, "$1$2") 'ヒットした部分を置換
        
        '拗音処理
        .Pattern = "([A-Z])iL(.)"
        wd = .Replace(wd, "$1$2")
        
        '促音処理
        .Pattern = "Ltu(.)"
        wd = .Replace(wd, "$1$1")
        
        '変換出来ないものの処理
        .Pattern = "(.+[ーぁぃぅぇぉ].{0,})"
        wd = .Replace(wd, "■$1") '先頭に■を入れて目立たせる
    End With
    
    KANA2ROMA = StrConv(wd, vbNarrow)
    KANA2ROMA = StrConv(wd, vbProperCase)
    
End Function

編集作業効率化用Excel関数

CHAIN(x1, x2)

x1 で指定したセル範囲に含まれる文字列を， x2 で指定した文字列を間に挟む形で連結する関数

' A1~D1セルが「あ」「い」「う」「え」の場合
=CHAIN(A1:D1,"／")
'  => あ／い／う／え
=CHAIN(A1:D1,"")
'  => あいうえ --- 間に何も挟まない場合

GETRUBY(x1(, x2))

• 指定したセル内の文字列をひらがなに変換する関数
• 原理としてはIMEの再変換を利用しているらしい。したがって必ずしも正しい日本語が返らないという欠点あり
• 省略可の x2 に「1」を指定するとカタカナに変換

=GETRUBY("伊藤")
'  => いとう
=GETRUBY("伊藤",1)
'  => イトウ

JUSHO(x1, x2)

• x1 で指定した住所の文字列を x2 に応じて「都道府県」「市区郡」「それ以降」に切り分ける
• 切り分けにはどうしても漏れが出るので注意

=JUSHO("東京都千代田区神田神保町2-17",1)
'  => 東京都
=JUSHO("東京都千代田区神田神保町2-17",2)
'  => 千代田区
=JUSHO("東京都千代田区神田神保町2-17",3)
'  => 神田神保町2-17

KANA2ROMA(x)

• ひらがな／カタカナをローマ字に変換する関数
• 「ぁ」「ぃ」「ぅ」「ぇ」「ぉ」および「ー（音引き）」は非対応

=KNA2ROMA("あいうえお")
'  => Aiueo
=KANA2ROMA("ろっぽんぎ")
'  => Roppongi --- 促音に対応
=KANA2ROMA("きみょう")
'  => Kimyou --- 拗音に対応
=KANA2ROMA("ファーム")
'  => ■fuァーmu --- 非対応文字が含まれる場合は先頭に"■"を出力

ROMA2KANA(x)

• x に含まれるアルファベットをひらがなに変換する関数
• 変換基準は編集2部の編集マニュアルに準拠

=ROMA2KANA("WHO憲章")
'  => だぶりゅーえいちおー憲章

SAKUYOMI(x)

• x で指定した文字列を索引でソートする形式に変換する関数

=SAKUYOMI("ドヴォルザーク")
'  => とうおるさく
=SAKUYOMI("じゃっく[A]")
'  => しやつく[A] --- 句読点などの記号は残る

VARIATION(x)

指定した範囲内に何種類のデータがあるのかをカウントする関数

' A1~D1セルが「あ」「い」「う」「あ」の場合
=VARIATION(A1:D1) 
'  => 3

WLOOKUP(x1, x2)

• VLOOKUP関数の簡易版
• x1 に検索したい文字列， x2 に検索範囲を指定すると， x1 範囲の左端列の中で検索して，ヒットした行の右端列のデータを返す
• ヒットしなかった場合は"【NoHit】"と表示

=WLOOKUP("あいう", A1:C45)
'  => A1:A45の範囲の中から"あいう"と含まれているセルを検索し，ヒットした場合は同行C列のデータを返す

ZEN2HAN(x)

x に含まれる全角英数を半角に変換する関数

=ZEN2HAN("０００ＡＢＣ")
'  => 000ABC