VBAマクロ向け関数。lunarkが日常で使っている関数集です。超小物もいっぱいあります。ほとんどがExcel専用と思って下さい。一応Excel2010を考慮しています。

関数集.bas

'******************************************************************
'■bottomRows関数
'Excel専用。特定の記入済みシートの末尾行を探す。
' 引数1：末尾判定対象シート：String
' 引数2：末尾判定対象列：String
' 返り値：末尾行番号：Double　※Excel2010対応のため
' Excel2003で使う場合は、1048576→65536へ変更のこと！
'******************************************************************

Function bottomRows(strSheetName As String, strColumnName As String) As Double
bottom = Sheets(strSheetName).Range(strColumnName & "1048576").End(xlUp).Row
End Function

'******************************************************************
'■FindRow関数
'特定のワークシート、特定の範囲内で、特定の文字列がある行を探す。
'常に上から探すので、対象となる表はソートされていることが望ましい。
'急場しのぎで作ったものなので、Excel専用。
' 引数1：検索対象シート名：String
' 引数2：検索対象列（A:A等）：String
' 引数3：検索ワード：String
' 返り値：検索したものがある行番号：Double　※Excel2010対応のため
'******************************************************************

Function FindRow(strSheetName as String, strRange as String, strSearchWord As String)As Double
Dim rng as Range
Set rng = Sheets(strSheetName).Range(strRange).Find(What:=strSearchWord, LookAt:=xlWhole) '検索範囲と検索条件を与えて検索を実行する
If rng Is Nothing Then
    Exit Function
End If
FindRow = rng.Row

End Function

'******************************************************************
'■NarrowNumOnly関数
'数字のみを半角に、カタカナ他すべてを全角にする。
' 引数：変換したい文字列：String
' 返り値：変換された文字列：String
'******************************************************************

Function NarrowNumOnly(strInput As String) As String

Dim strRet As String
Dim intLoop As Integer
Dim strChar As String

    strInput = StrConv(strInput, vbWide)

    For intLoop = 1 To Len(strInput)
        strChar = Mid(strInput, intLoop, 1)
        If (strChar >= "０" And strChar <= "９") Or (strChar >= "Ａ" And strChar <= "Ｚ") Or (strChar >= "ａ" And strChar <= "ｚ") Or strChar = "－" Then
            strRet = strRet & StrConv(strChar, vbNarrow)
         Else
        strRet = strRet & strChar
        End If
    Next intLoop

    NarrowNumOnly = strRet
End Function

'******************************************************************
'■GetWebStatus関数
'そのURL上に、実際にWebサイトが存在するのかをチェックするのに使う。
'URLの入力ミスチェックに利用する関数。
' 引数1：URL：String
' 返り値：HTTPステータス（3桁コードあるいは「INVALID URL」「TIMEOUT」）：Stringで帰る点に注意！
'急場しのぎで作ったので、XMLHTTPRequest 6.0必須
'******************************************************************

Function GetWebStatus(url As String) As String

  Dim url2 As String
  Dim timeout As Double
  Dim timeoutTime As Double
  Dim XMLHttp As Object
  Set XMLHttp = CreateObject("Msxml2.ServerXMLHTTP.6.0")
    
On Error GoTo INVALID
    
    timeout = 20
    timeoutTime = Timer + timeout

'プロキシ経由接続が要る場合はここで設定する！
'    XMLHttp.setProxy "2", "192.168.0.1:8080", "*.proxy.contoso.com"
    XMLHttp.Open "GET", url, True
    XMLHttp.send
  Do
     DoEvents
     If Timer > timeoutTime Then GoTo TIMEOUTERR
  Loop While XMLHttp.readyState <> 4
  
  GetWebStatus = XMLHttp.Status

  Set XMLHttp = Nothing

  Exit Function

TIMEOUTERR:
  GetWebStatus = "TIMEOUT"
  Set XMLHttp = Nothing
Exit Function

INVALID:
  GetWebStatus = "INVALID URL"
  Set XMLHttp = Nothing
End Function