Skip to content

Instantly share code, notes, and snippets.

@lunark
Last active June 25, 2020 08:37
Show Gist options
  • Save lunark/8328254 to your computer and use it in GitHub Desktop.
Save lunark/8328254 to your computer and use it in GitHub Desktop.
VBAマクロ向け関数。lunarkが日常で使っている関数集です。超小物もいっぱいあります。ほとんどがExcel専用と思って下さい。一応Excel2010を考慮しています。
'******************************************************************
'■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 >= "0" And strChar <= "9") Or (strChar >= "A" And strChar <= "Z") Or (strChar >= "a" And strChar <= "z") 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment