HOME > エクセルVBA > サンプル > ユーザー定義関数zs

ユーザー定義関数zs


【ファイル名】zs.xlam
【バージョン】Ver 1.0.5.2
【作成日】2016年10月08日
【更新日】2019年06月06日
【動作確認】Windows Vista
【必要なソフト】Microsoft Excel 2007以降
【説明】ユーザー定義関数zsのソースです。

Privateで宣言した関数はボツです。使用する場合はPublicに変更してください。
関数の挿入ダイアログに表示するにはApplication.MacroOptionsを使用してください。

zsファイル/フォルダ
Option Explicit

' 現在のドライブのパスを返します。
Private Function zsCurDir(Optional ByVal ドライブ As String = "") As String
  Application.Volatile ' 自動再計算関数

  zsCurDir = CurDir(ドライブ)
End Function

' フォルダが存在しているか返します。(TRUE, FALSE)
Public Function zsFolderExists(ByVal フォルダ名 As String) As Boolean
  Dim FSO

  Application.Volatile ' 自動再計算関数
  Set FSO = CreateObject("Scripting.FileSystemObject")
  zsFolderExists = FSO.FolderExists(フォルダ名)
  Set FSO = Nothing
End Function

' 指定したファイルが存在しているか返します。(TRUE, FALSE)
Function zsFileExists(ByVal ファイル名 As String) As Boolean
  Application.Volatile ' 自動再計算関数
  zsFileExists = Len(Dir(ファイル名)) > 0
End Function

' パス名に拡張子があるか?
Private Function IsExt(ByVal パス名 As String) As Boolean
  Dim dot As Long
  Dim yen As Long
  Dim l As Long

  dot = InStrRev(パス名, ".", Compare:=vbBinaryCompare)
  yen = InStrRev(パス名, Application.PathSeparator, Compare:=vbBinaryCompare)
  l = Len(パス名)
  IsExt = (dot > yen) And (dot <> l) ' .は\よりも右、.は最後ではいけません!
  ' ..\temp = False
  ' test.   = False
  ' .txt    = True
End Function

' パス名から拡張子を取得します。(ドット「.」を含みます。)拡張子がない場合は""
Public Function zsGetExt(ByVal パス名 As String) As String
  Dim dot As Long

  If zsFolderModule.IsExt(パス名) = False Then
    zsGetExt = ""
    Exit Function
  End If

  dot = InStrRev(パス名, ".", Compare:=vbBinaryCompare)
  zsGetExt = Mid(パス名, dot)
End Function

' パス名からパスを除いて、ファイル名を取得します。ファイル名がない場合は""
Public Function zsGetFileName(ByVal パス名 As String) As String
  Dim yen As Long
  Dim l As Long

  zsGetFileName = ""
  yen = InStrRev(パス名, Application.PathSeparator, Compare:=vbBinaryCompare)
  l = Len(パス名)

  If パス名 = "." Then Exit Function
  If パス名 = ".." Then Exit Function
  If (l = 2) And (InStr(1, パス名, ":", vbBinaryCompare) = 2) Then Exit Function ' ドライブのみ
  If yen < 1 Then
    zsGetFileName = パス名
  Else
    If l > yen Then zsGetFileName = Mid$(パス名, yen + 1)
  End If
End Function

' パス名からファイル名を除いて、パスを取得します。(最後に「\」はつきません。コロン「:」がなくかつ円記号「\」がない場合はファイルとします)
Public Function zsGetPathName(ByVal パス名 As String) As String
  Dim yen As Long
  Dim l As Long
  Dim colon As Long

  yen = InStrRev(パス名, Application.PathSeparator, Compare:=vbBinaryCompare)
  colon = InStrRev(パス名, ":", Compare:=vbBinaryCompare)
  l = Len(パス名)

  zsGetPathName = パス名
  If パス名 = "." Then Exit Function
  If パス名 = ".." Then Exit Function

  If yen > 0 Then
    zsGetPathName = Left$(パス名, yen - 1)
  ElseIf colon > 0 Then
    zsGetPathName = パス名 ' ドライブ
  Else
    zsGetPathName = "" ' 円記号「\」がない場合はファイルとします
  End If
End Function

' パス名の最後に「\」を付けます。(最後が既に「\」の場合は付けません)【注意】パスが拡張子のないファイル名の場合も「\」を付けます。
Public Function zsAddBackSlash(ByVal パス名 As String) As String
  Dim yen As Long
  Dim dot As Long
  Dim l As Long

  zsAddBackSlash = パス名
  yen = InStrRev(パス名, Application.PathSeparator, Compare:=vbBinaryCompare)
  dot = InStrRev(パス名, ".", Compare:=vbBinaryCompare)
  l = Len(パス名)

  If yen = l Then Exit Function ' 最後が既に「\」
  If (l > 2) And (dot = l) Then Exit Function ' 3文字以上でかつ最後が「.」

  If zsFolderModule.IsExt(パス名) = False Then
    zsAddBackSlash = パス名 & Application.PathSeparator
  End If
End Function

' パス名の最後の「\」を削除します。
Public Function zsRemoveBackSlash(ByVal パス名 As String) As String
  Dim yen As Long
  Dim l As Long

  yen = InStrRev(パス名, Application.PathSeparator, Compare:=vbBinaryCompare)
  l = Len(パス名)

  If l < 1 Then
    zsRemoveBackSlash = ""
  ElseIf yen = l Then
    zsRemoveBackSlash = Left$(パス名, yen - 1)
  Else
    zsRemoveBackSlash = パス名
  End If
End Function

' パス名からドライブ名を取得します。(2文字目がコロン「:」かを判断します。)
Public Function zsGetDriveName(ByVal パス名 As String) As String
  Dim colon As Long

  colon = InStr(1, パス名, ":", vbBinaryCompare)
  If colon = 2 Then
    zsGetDriveName = Left$(パス名, 2)
  Else
    zsGetDriveName = ""
  End If
End Function

' パス名の拡張子を削除します。
Public Function zsRemoveExt(ByVal パス名 As String) As String
  Dim dot As Long
  Dim l As Long

  dot = InStrRev(パス名, ".", Compare:=vbBinaryCompare)
  l = Len(パス名)
  zsRemoveExt = パス名
  If IsExt(パス名) Then ' 拡張子がある場合は
  
    If (l = dot) And (l > 2) And (Mid$(パス名, l - 1, 1) <> ".") Then ' 最後がドット「.」でかつ最後から2文字目がドット「.」以外
      zsRemoveExt = Left$(パス名, l - 1) ' 最後のドット「.」を削除します。
    Else
      zsRemoveExt = Left$(パス名, dot - 1)
    End If
    
  End If
End Function


' パス名の拡張子を変更します。(拡張子にドット「.」を含みます)
Public Function zsChangeFileExt(ByVal パス名 As String, ByVal 拡張子 As String) As String
  Dim dot As Long
  Dim yen As Long
  Dim colon As Long
  Dim l As Long
  Dim ext As String

  dot = InStrRev(パス名, ".", Compare:=vbBinaryCompare)
  yen = InStrRev(パス名, Application.PathSeparator, Compare:=vbBinaryCompare)
  colon = InStrRev(パス名, ":", Compare:=vbBinaryCompare)
  l = Len(パス名)

  ' 拡張子を削除します。
  If (Len(拡張子) < 1) Or 拡張子 = "." Then
    zsChangeFileExt = zsFolderModule.zsRemoveExt(パス名)
    Exit Function
  End If

  ext = 拡張子
  If InStrRev(拡張子, ".", Compare:=vbBinaryCompare) < 1 Then
    ext = zsChangeFileExt & "." & 拡張子 ' 新しい拡張子にドット「.」がない場合は追加します。
  End If

  If zsFolderModule.IsExt(パス名) Then ' 拡張子がある場合は
    zsChangeFileExt = zsFolderModule.zsRemoveExt(パス名) & ext ' 拡張子を変更します。
  Else
    If (dot = l) Or (yen = l) Or (colon = l) Then  ' 空かドライブか最後がディレクトリ
      zsChangeFileExt = パス名 ' 何もしない
    Else ' ファイル
      zsChangeFileExt = パス名 & ext ' 拡張子を追加します。
    End If
  End If
End Function

' 指定した左側の連続する文字を削除します。
Private Function DelLeft(ByVal 対象文字列 As String, Optional ByVal 削除する文字 As String = """", Optional ByVal 比較方法 As VbCompareMethod = vbBinaryCompare) As String
  Dim i As Long, l As Long, p As Long, DelLength As Long, Count As Long

  l = Len(対象文字列)
  DelLength = Len(削除する文字)
  DelLeft = 対象文字列
  If (l < 1) Or (DelLength < 1) Then ' 削除できない場合は終了します。
    Exit Function
  End If

  Count = 0
  i = 1
  Do While (i <= l)
    p = InStr(i, 対象文字列, 削除する文字, 比較方法)
    If p <> i Then
      Exit Do
    Else
      Count = Count + 1
      i = i + DelLength
    End If
  Loop

  If Count > 0 Then ' 削除する文字があった場合は
    If (Count * DelLength) < l Then
      DelLeft = Mid$(対象文字列, Count * DelLength + 1) ' 左側を削除します。
    Else
      DelLeft = "" ' すべて削除します。
    End If
  End If
End Function

' 指定した右側の連続する文字を削除します。
Private Function DelRight(ByVal 対象文字列 As String, Optional ByVal 削除する文字 As String = """", Optional ByVal 比較方法 As VbCompareMethod = vbBinaryCompare) As String
  Dim i As Long, l As Long, p As Long, DelLength As Long, Count As Long

  l = Len(対象文字列)
  DelLength = Len(削除する文字)
  DelRight = 対象文字列
  If (l < 1) Or (DelLength < 1) Then ' 削除できない場合は終了します。
    Exit Function
  End If

  Count = 0
  i = l
  Do While (i > 0)
    p = InStrRev(対象文字列, 削除する文字, i, Compare:=比較方法)
    If p < 1 Then Exit Do ' ない場合
    If p <> (i - DelLength + 1) Then ' あっても既に違う文字が出た
      Exit Do
    Else ' 連続した削除する文字
      Count = Count + 1
      i = i - DelLength
    End If
  Loop

  If Count > 0 Then ' 削除する文字があった場合は
    If (Count * DelLength) < l Then
      DelRight = Left$(対象文字列, l - (Count * DelLength)) ' 右側を削除します。
    Else
      DelRight = "" ' すべて削除します。
    End If
  End If
End Function

' 左側と右側の連続する二重引用符「"」を削除します。その後で二重引用符「"」で囲みます。(途中に含まれる二重引用符は変更しません)
Private Function QuoteSpaces(ByVal パス名 As String) As String
  QuoteSpaces = """" & zsFolderModule.UnquoteSpaces(パス名) & """"
End Function

' 左側と右側の連続する二重引用符「"」を削除します。
Private Function UnquoteSpaces(ByVal パス名 As String) As String
  UnquoteSpaces = zsFolderModule.DelLeft(zsFolderModule.DelRight(パス名))
End Function
このページの上

zs文字列操作
Option Explicit
Option Base 0         ' 配列の添字の既定値を 0 に設定

' 文字列を数値に変換します。
Function zsValue(ByVal 数値の文字列 As String) As Double
  Dim s As String
  
  s = StrConv(数値の文字列, vbNarrow)
  s = Replace(s, "金", "")
  s = Replace(s, "消費税", "")
  s = Replace(s, "合計", "")
  s = Replace(s, "\", "")
  s = Replace(s, ",", "")
  zsValue = Val(s)
End Function

' 対象の文字列を正規表現で検索して見つけた最初の位置を返します。(見つからない場合は0を返します)
' 「ツール」の「参照設定」メニューで「Microsoft VBScript Regular Expressions 5.5」を追加
Function zsRegExpFind(ByVal 対象の文字列 As String, ByVal 検索文字列 As String, Optional ByVal 大文字と小文字を区別する As Boolean = False) As Integer
  Dim re As New RegExp
  Dim ms As MatchCollection
  Dim m As Match
  
  re.Global = False
  re.MultiLine = True
  re.Pattern = 検索文字列
  re.IgnoreCase = Not 大文字と小文字を区別する
  Set ms = re.Execute(対象の文字列)
  If ms.Count > 0 Then
    zsRegExpFind = ms(0).FirstIndex + 1
  Else
    zsRegExpFind = 0
  End If
  Set ms = Nothing
End Function

' 対象の文字列を正規表現で検索して置き換えた文字列を返します。
' 「ツール」の「参照設定」メニューで「Microsoft VBScript Regular Expressions 5.5」を追加
Function zsRegExpReplace(ByVal 対象の文字列 As String, ByVal 検索文字列 As String, ByVal 置換文字列 As String, Optional ByVal 大文字と小文字を区別する As Boolean = False) As String
  Dim re As New RegExp
  
  re.Global = True
  re.MultiLine = True
  re.Pattern = 検索文字列
  re.IgnoreCase = Not 大文字と小文字を区別する
  zsRegExpReplace = re.Replace(対象の文字列, 置換文字列)
End Function

' 指定した文字列の数を返します。
Function zsTextLen(ByVal 文字列 As String, ByVal 数える文字列 As String, Optional ByVal 大文字と小文字を区別 As Boolean = False) As Long
  Dim s As String
  
  zsTextLen = 0
  If Len(数える文字列) < 1 Then Exit Function ' Div by 0 Error
  
  If 大文字と小文字を区別 Then
    s = Replace(文字列, 数える文字列, "", Compare:=vbBinaryCompare)
  Else
    s = Replace(文字列, 数える文字列, "", Compare:=vbTextCompare)
  End If
  
  zsTextLen = (Len(文字列) - Len(s)) \ Len(数える文字列)
End Function

' 指定した文字列から指定した文字を削除した文字列を返します。(省略値="ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")
Function zsDelChars(ByVal 文字列 As String, Optional ByVal 削除する複数の文字 As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz") As String
  Dim i As Integer
  Dim j As Integer
  Dim l As Integer
  Dim c As String
  Dim s As String
  Dim find As Boolean
  
  s = ""
  l = Len(文字列)
  For i = 1 To l
    c = Mid(文字列, i, 1)
    find = False
    For j = 1 To Len(削除する複数の文字)
      If c = Mid(削除する複数の文字, j, 1) Then
        find = True
        Exit For
      End If
    Next j
    If find = False Then
      s = s & c
    End If
  Next i
  zsDelChars = s
End Function

' 指定した文字列から指定した文字を削除した文字列を返します。Likeバージョン(省略値="A-Za-z")
Private Function zsDelCharsLike(ByVal 文字列 As String, Optional ByVal 削除する複数の文字 As String = "[A-Za-z]") As String
  Dim i As Integer
  Dim l As Integer
  Dim c As String
  Dim s As String
  
  s = ""
  l = Len(文字列)
  For i = 1 To l
    c = Mid(文字列, i, 1)
    If Not c Like 削除する複数の文字 Then
      s = s & c
    End If
  Next i
  zsDelCharsLike = s
End Function

' 指定した文字列から指定した文字のみ取得します。(省略値="0123456789")
Function zsGetChars(ByVal 文字列 As String, Optional ByVal 取得する複数の文字 As String = "0123456789") As String
  Dim i As Integer
  Dim j As Integer
  Dim l As Integer
  Dim c As String
  Dim s As String
  
  s = ""
  l = Len(文字列)
  For i = 1 To l
    c = Mid(文字列, i, 1)
    For j = 1 To Len(取得する複数の文字)
      If c = Mid(取得する複数の文字, j, 1) Then
        s = s & c
        Exit For
      End If
    Next j
  Next i
  zsGetChars = s
End Function

' 指定した文字列から指定した文字のみ取得します。Likeバージョン(省略値="0-9")
Private Function zsGetCharsLike(ByVal 文字列 As String, Optional ByVal 取得する複数の文字 As String = "[0-9]") As String
  Dim i As Integer
  Dim l As Integer
  Dim c As String
  Dim s As String
  
  s = ""
  l = Len(文字列)
  For i = 1 To l
    c = Mid(文字列, i, 1)
    If c Like 取得する複数の文字 Then
      s = s & c
    End If
  Next i
  zsGetCharsLike = s
End Function

' 半角の英字のみ大文字に変換します。
Function zsHanUpper(ByVal 文字列 As String) As String
  Dim i As Integer
  Dim l As Integer
  Dim c As String
  Dim s As String
  
  s = ""
  l = Len(文字列)
  For i = 1 To l
    c = Mid(文字列, i, 1)
    If c Like "[a-z]" Then c = StrConv(c, vbUpperCase)
    s = s & c
  Next i
  zsHanUpper = s
End Function

' 半角の英字のみ小文字に変換します。
Function zsHanLower(ByVal 文字列 As String) As String
  Dim i As Integer
  Dim l As Integer
  Dim c As String
  Dim s As String
  
  s = ""
  l = Len(文字列)
  For i = 1 To l
    c = Mid(文字列, i, 1)
    If c Like "[A-Z]" Then c = StrConv(c, vbLowerCase)
    s = s & c
  Next i
  zsHanLower = s
End Function

' 指定した文字列の文字の並び順を逆にした文字列を返します。
Function zsStrReverse(ByVal 文字列 As String) As String
  zsStrReverse = StrReverse(文字列)
End Function

' 文字列の先頭の半角と全角スペースを削除した文字列を返します。
Function zsLTrim(ByVal 文字列 As String) As String
  zsLTrim = LTrim(文字列)
End Function

' 文字列の末尾の半角と全角スペースを削除した文字列を返します。
Function zsRTrim(ByVal 文字列 As String) As String
  zsRTrim = RTrim(文字列)
End Function

' 文字列の先頭と末尾の半角と全角スペースを削除した文字列を返します。
Function zsTrim(ByVal 文字列 As String) As String
  zsTrim = Trim(文字列)
End Function

' 指定した末尾の位置から文字列を検索します。(英字の大文字と小文字を区別しない)
Function zsSearchRev(ByVal 対象の文字列 As String, ByVal 検索文字列 As String, Optional ByVal 開始位置 As Long = -1) As Long
  zsSearchRev = InStrRev(対象の文字列, 検索文字列, 開始位置, vbTextCompare)
End Function

' 指定した末尾の位置から文字列を検索します。(英字の大文字と小文字を区別する)
Function zsFindRev(ByVal 対象の文字列 As String, ByVal 検索文字列 As String, Optional ByVal 開始位置 As Long = -1) As Long
  zsFindRev = InStrRev(対象の文字列, 検索文字列, 開始位置, vbBinaryCompare)
End Function

' 指定した末尾の位置から文字列を検索します。(比較法は省略か0は大文字と小文字を区別する、1は区別しません)
' 引数の比較方法でvbDatabaseCompareは使用しません。
Function zsInStrRev(ByVal 対象の文字列 As String, ByVal 検索文字列 As String, Optional ByVal 開始位置 As Long = -1, Optional ByVal 比較方法 As VbCompareMethod = vbBinaryCompare) As Long
    If 比較方法 = vbTextCompare Then
      zsInStrRev = InStrRev(対象の文字列, 検索文字列, 開始位置, vbTextCompare)
    Else
      zsInStrRev = InStrRev(対象の文字列, 検索文字列, 開始位置, vbBinaryCompare)
    End If
End Function

' 英数字は半角に、カタカナは全角にします。
 Private Function zsZenKatakanaHanNumAlpha(ByVal 文字列 As String) As String
  Dim i As Long
  Dim l As Long
  Dim s As String
  Dim c As String

  s = StrConv(文字列, vbWide) ' 全角に変換する
  l = Len(s)
  For i = 1 To l
    c = Mid(s, i, 1)
    If Not c Like "[ァ-ヶ、。゛゜ー]" Then ' カタカナ以外は
      Mid(s, i, 1) = StrConv(c, vbNarrow) ' 数字、英字、記号は半角に変換します。漢字は半角にはなりません。
    End If

  Next i
  zsZenKatakanaHanNumAlpha = s
End Function

' 漢字のヨミを取得します。
' フリガナ形式が0は全角のカタカナ、1は半角のカタカナ、2はひらがな
Function zsPhontic(ByVal 漢字 As String, Optional ByVal フリガナ形式 As Long = 0) As String
  If フリガナ形式 = 1 Then
    zsPhontic = StrConv(Application.GetPhonetic(漢字), vbNarrow)
  ElseIf フリガナ形式 = 2 Then
    zsPhontic = StrConv(Application.GetPhonetic(漢字), vbHiragana)
  Else
    zsPhontic = Application.GetPhonetic(漢字)
  End If
End Function

' 漢字の読みをふりがなで返します。
Function zsふりがな(ByVal 漢字 As String)
  zsふりがな = StrConv(Application.GetPhonetic(漢字), vbHiragana)
End Function

' 漢字の読みを全角のカタカナで返します。
Function zs全角フリガナ(ByVal 漢字 As String)
  zs全角フリガナ = Application.GetPhonetic(漢字)
End Function

' 漢字の読みを半角のカタカナで返します。
Function zs半角フリガナ(ByVal 漢字 As String)
  zs半角フリガナ = StrConv(Application.GetPhonetic(漢字), vbNarrow)
End Function

' ひらがなを全角カタカナにします。
Function zsKatakana(ByVal ひらがな As String) As String
  zsKatakana = StrConv(ひらがな, vbKatakana)
End Function
' 全角カタカナをひらがなにします。
Function zsHiragana(ByVal 全角カタカナ As String) As String
  zsHiragana = StrConv(全角カタカナ, vbHiragana)
End Function

' 引数がセル(Rangeオブジェクト)か検査します。
Private Function IsRange(ByVal セル As Variant) As Boolean
  Dim r As Range
  
  On Error Resume Next
  Err.Clear
  Set r = セル
  IsRange = (Err.Number = 0)
  On Error GoTo 0
End Function

' 指定したセル範囲の値を連結した文字列を返します。
' Excel2016ではCONCAT関数があります。
' セル範囲は複数のエリアで、離れた複数のセル範囲も可能です。セルでなく文字列も指定できます。
Function zsConCat(ParamArray セル範囲() As Variant) As String
  Dim i As Integer ' Areas
  Dim x As Integer ' Column
  Dim y As Integer ' Row
  Dim r As Range ' 1つのエリア
  Dim s As String  ' セルの値を連結する文字列
  
  s = ""
  For i = LBound(セル範囲) To UBound(セル範囲)
    If StringModule.IsRange(セル範囲(i)) Then
      Set r = セル範囲(i)
      For y = 1 To r.Rows.Count
        For x = 1 To r.Columns.Count
          s = s & r.Cells(y, x).Value
        Next x
      Next y
    Else
      s = s & セル範囲(i)
    End If
  Next i
  
  zsConCat = s
End Function

' 指定したセル範囲の値を、区切り記号で連結した文字列を返します。
' 区切り記号を省略した場合はカンマ(,)です。
' Excel2016ではTEXTJOIN関数があります。
' セル範囲は複数の連続するセルのアドレスです。文字列定数は指定できません!
Function zsJoin(ByVal セル範囲 As Range, Optional ByVal 区切り記号 As String = ",") As String
  Dim i As Integer ' Areas
  Dim x As Integer ' Column
  Dim y As Integer ' Row
  Dim Value As String  ' セルの値
  Dim s As String  ' セルの値を連結する文字列
  
  s = ""
  For i = 1 To セル範囲.Areas.Count
    For y = 1 To セル範囲.Areas(i).Rows.Count
      For x = 1 To セル範囲.Areas(i).Columns.Count
        Value = セル範囲.Areas(i).Cells(y, x).Value
        If (i = 1) And (y = 1) And (x = 1) Then
          s = Value
        Else
          s = s & 区切り記号 & Value
        End If
      Next x
    Next y
  Next i
  
  zsJoin = s
End Function

' 指定したセル範囲の値を、区切り記号で連結した文字列を返します。
' Excel2016ではTEXTJOIN関数があります。
' セル範囲は複数のセルです。離れたセルも指定できます。セルでなく文字列も指定できます。
Function zsTextJoin(ByVal 区切り記号 As String, ByVal Ignore_Empty As Boolean, ParamArray セル範囲() As Variant) As String
  Dim p As Integer ' Param Array
  Dim a As Integer ' Areas
  Dim x As Integer ' Column
  Dim y As Integer ' Row
  Dim Value As String  ' セルの値
  Dim s As String  ' セルの値を連結する文字列
  Dim r As Range ' 1つのエリア
  
  s = ""
  For p = LBound(セル範囲) To UBound(セル範囲)
    If StringModule.IsRange(セル範囲(p)) Then
      Set r = セル範囲(p)
      For a = 1 To r.Areas.Count
        For y = 1 To r.Areas(a).Rows.Count
          For x = 1 To r.Areas(a).Columns.Count
            Value = r.Areas(a).Cells(y, x).Value
              If (Len(Value) < 1) And (Ignore_Empty = True) Then
                ' 何もしない
              Else
                If a = 1 And y = 1 And x = 1 Then
                  s = Value
                Else
                  s = s & 区切り記号 & Value
                End If
              End If
          Next x
        Next y
      Next a
    Else
      If (Len(セル範囲(p)) < 1) And (Ignore_Empty = True) Then
        ' 何もしない
      Else
        If p = 0 Then
          s = セル範囲(p)
        Else
          s = s & 区切り記号 & セル範囲(p)
        End If
      End If
    End If
  Next p
  
  zsTextJoin = s
End Function

' 文字列から指定した開始位置から、指定した文字数分の文字列を返します。
' 文字数を省略した場合は最後までです。
Public Function zsMid(ByVal 文字列 As String, ByVal 開始位置 As Long, Optional ByVal 文字数 As Variant) As String
  If IsMissing(文字数) Then
    zsMid = Mid(文字列, 開始位置)
  Else
    zsMid = Mid(文字列, 開始位置, 文字数)
  End If
End Function

' 半角のカタカナのみを全角にします。
Public Function zsHanKana2Zen(ByVal Han As String) As String
' 「ア゚」などの変換できない半角の濁音(゙)や半濁音(゚)は全角の濁音(゛)や半濁音(゜)にします。(結合文字にはしません)
' この関数は半角カタカナに記号を含めたUnicodeのFF61-FF9Fの範囲とします。(。)から(゚)まで 【注意】サンプルの多くは「ヲ」から「ン」としてます。
' 。「」、・ヲァィゥェォャュョッーアイウエオカキクケコサシスセソタチツテトナニヌネノハヒフヘホマミムメモヤユヨラリルレロワン゙゚
' この関数では半角カタカナにカナ記号(。「」、・)を含め、半角の空白は含めません。
  Dim c As String, s As String, h As String
  Dim i As Long, l As Long

  l = Len(Han)
  s = ""
  zsHanKana2Zen = ""
  For i = 1 To l
    c = Mid$(Han, i, 1) ' 1文字づつ取得します。
    If c Like "[。-゚]" Then ' 半角カタカナの場合は
      s = s & c ' 濁音や半濁音があるため、まとめてから全角に変換する必要があります。
      If c = "゙" Or c = "゚" Then ' 濁音(゙)や半濁音(゚)
        zsHanKana2Zen = zsHanKana2Zen & StrConv(s, vbWide)
        h = Right$(zsHanKana2Zen, 1) ' 最後の文字
        If h = "?" Then ' 変換できない場合は
          zsHanKana2Zen = Left$(zsHanKana2Zen, Len(zsHanKana2Zen) - 1) ' 最後の文字を削除
          If c = "゙" Then  ' 濁点
            zsHanKana2Zen = zsHanKana2Zen & "゛" ' 全角の濁点を追加します
          End If
          If c = "゚" Then ' 半濁点
            zsHanKana2Zen = zsHanKana2Zen & "゜" ' 全角の半濁点を追加します
          End If
        End If
        s = ""
      End If
    Else
      zsHanKana2Zen = zsHanKana2Zen & StrConv(s, vbWide) & c
      s = ""
    End If
  Next i

  If s <> "" Then ' まだ半角カタカナを変換していない場合は
    zsHanKana2Zen = zsHanKana2Zen & StrConv(s, vbWide)
  End If
End Function

' 文字列がパターンに合うかを返します。
Private Function zsIsPattern(ByVal 検索の対象 As String, ByVal 検索のパターン As String) As Boolean
' ? ・・・・・ 任意の1文字
' * ・・・・・ 0 個以上の文字
' # ・・・・・ 任意の1桁 (0?9)
' [文字] ・・・ 文字に含まれる任意の1文字 小文字の英字は[a-z]、大文字の英字は[A-Z]、 。「」、・の記号を含む半角カタカナは[。-゚]
' [!文字]・・・ 文字に含まれない任意の1文字
  zsIsPattern = (検索の対象 Like 検索のパターン)
End Function

' ● 「データ」タブの「データツール」グループの「区切り位置」ボタンがあるのでこの関数は必要ありません。
' 指定した文字列を区切り記号で分割して、文字列を右方向に返します。
' 配列数式です。事前に必要な複数のセルを選択して、Shift+Ctrl+Enterキーを押します。
Private Function zsSplit(ByVal 文字列 As String, Optional ByVal 区切り記号 As String = ",") As Variant
  zsSplit = Split(文字列, 区切り記号, -1, vbBinaryCompare)
End Function

' 指定した文字列を区切り記号で分割して、文字列を下方向に返します。
' 配列数式です。事前に必要な複数のセルを選択して、Shift+Ctrl+Enterキーを押します。
Private Function zsVSplit(ByVal 文字列 As String, Optional ByVal 区切り記号 As String = ",") As Variant
  Dim v, ar() As Variant
  Dim n As Integer
  Dim i As Integer
  
  v = Split(文字列, 区切り記号, -1, vbBinaryCompare)
  n = UBound(v) - LBound(v)
  ReDim Preserve ar(n, 0)
  For i = LBound(v) To UBound(v)
    ar(i, 0) = v(i)
  Next i
  zsVSplit = ar
End Function

' 指定した先頭の文字数を削除します。
Private Function zsCutLeft(ByVal 文字列 As String, Optional ByVal 削除する文字数 As Integer = "1") As String
  Dim l As Integer
  
  If 削除する文字数 < 1 Then
    zsCutLeft = 文字列
    Exit Function
  End If
  
  l = Len(文字列)
  If 削除する文字数 >= l Then
    zsCutLeft = ""
  Else
    zsCutLeft = Mid(文字列, 削除する文字数 + 1)
  End If
End Function

' 指定した末尾の文字数を削除します。
Private Function zsCutRight(ByVal 文字列 As String, Optional ByVal 削除する文字数 As Integer = "1") As String
  Dim l As Integer
  
  If 削除する文字数 < 1 Then
    zsCutRight = 文字列
    Exit Function
  End If
  
  l = Len(文字列)
  If 削除する文字数 >= l Then
    zsCutRight = ""
  Else
    zsCutRight = Left(文字列, l - 削除する文字数)
  End If
End Function

' 指定した位置に文字列を挿入します。
Private Function zsInsert(ByVal 対象文字列 As String, ByVal 挿入する文字列 As String, Optional ByVal 挿入する位置 As Long = 1) As String
  If 挿入する位置 < 1 Then
    zsInsert = 挿入する文字列 & 対象文字列
  Else
    zsInsert = Application.WorksheetFunction.Replace(対象文字列, 挿入する位置, 0, 挿入する文字列)
  End If
End Function

' 漢字の数値の文字列を返します。(NUMBERSTRING関数は「関数の挿入」ダイアルログに表示されません)
'     書式=1 十二億三千四百五十六万七千八百九十
'     書式=2 壱拾弐億参阡四百伍拾六萬七阡八百九拾
'     書式=3 一二三四五六七八九〇
Private Function zsNUMBERSTRING(ByVal 数値 As Long, Optional ByVal 書式 As Long = 1) As String
  Dim Num As Long
  
  If 書式 < 1 Or 書式 > 3 Then
    Num = 1
  Else
    Num = 書式
  End If
  zsNUMBERSTRING = Application.Evaluate("NUMBERSTRING(""" & 数値 & """,""" & Num & """)")
End Function

' 指定した数値に対応する文字を返します。
' 数値の範囲は -32768 〜 65535
' 数値の9はタブ、10は改行、13は復帰
' Excel Onlineで使用できる制御コードは、9,10,13です。
' CHAR(10)で改行されないセルは「ホーム」タブの「配置」グループの「折り返して全体を表示する」を選択してください。
Private Function zsChrW(ByVal 数値 As Long) As String
  zsChrW = ChrW(数値)
End Function

' HTMLの特殊文字のエスケープ(無効)
' 「&」を「&amp;」に変換します。
' 「<」を「&lt;」に変換します。
' 「>」を「&gt;」に変換します。
' 「"」を「&quot;」に変換します。
' 「'」を「&#039;」に変換します。
' 半角スペースの「 」を「&nbsp;」に変換します。
Private Function EscapeHTML(ByVal Text As String) As String
  Dim s As String
  
  s = Replace(Text, "&", "&amp;", Compare:=vbBinaryCompare) ' ◆ 最初に&を置き換えること!
  s = Replace(s, "<", "&lt;", Compare:=vbBinaryCompare)
  s = Replace(s, ">", "&gt;", Compare:=vbBinaryCompare)
  s = Replace(s, """", "&quot;", Compare:=vbBinaryCompare)
  s = Replace(s, "'", "&#039;", Compare:=vbBinaryCompare)
  s = Replace(s, " ", "&nbsp;", Compare:=vbBinaryCompare) ' 半角スペース
  EscapeHTML = s
End Function
このページの上

zs日付/時刻
Option Explicit

' 2 つの日付間の日数、月数、年数を計算します。(ExcelのDATEDIF関数)
' DATEDIF関数は「関数の挿入」ダイアログには表示されません。
'"Y" 期間の年数です。
'"M" 期間の月数です。
'"D" 期間の日数です。
'"MD"  開始日から終了日までの日数です。 日付の月数および年数は無視されます。
'"YM"  開始日から終了日までの月数です。 日付の日数および年数は無視されます。
'"YD"  開始日から終了日までの日数です。 日付の年数は無視されます。
Function zsDATEDIF(ByVal 開始日 As Date, ByVal 終了日 As Date, ByVal 日付形式 As String) As Variant
  zsDATEDIF = Application.Evaluate("DATEDIF(""" & 開始日 & """,""" & 終了日 & """,""" & 日付形式 & """)")
End Function

' 2 つの日付間の日数、月数、年数を計算します。(VBAのDateDiff関数)
'yyyy 年
'q 四半期
'm 月
'y 年間通算日
'd 日
'w 週日
'ww 週
'h 時
'n 分
's 秒
'
'名前付き引数 firstdayofweek の設定値は次のとおりです。
' 1 日曜(既定値)
' 2 月曜
' 3 火曜
' 4 水曜
' 5 木曜
' 6 金曜
' 7 土曜
'
'名前付き引数 firstweekofyear の設定値は次のとおりです。
' 1 1月1日を含む週を年度の第1週として扱います。(既定値)
' 2 7日のうち少なくとも4日が新年度に含まれる週を年度の第1週として扱います。
' 3 全体が新年度に含まれる最初の週を年度の第1週として扱います。
Function zsDateDiff(ByVal 日付形式 As String, ByVal 開始日 As Date, ByVal 終了日 As Date, Optional ByVal FirstDayOfWeek As VbDayOfWeek = 1, Optional ByVal FirstWeekOfYear As VbFirstWeekOfYear = 1) As Long
  zsDateDiff = DateDiff(日付形式, 開始日, 終了日, FirstDayOfWeek, FirstWeekOfYear)
End Function

' 指定された日付を加算した日付を返します。
' 日付形式は上のDateDiff関数を参照。
Function zsDateAdd(ByVal 日付形式 As String, ByValAs Double, ByVal 日付) As Variant
  zsDateAdd = DateAdd(日付形式, 数, 日付)
End Function

' 指定した日付の前月の日付を返します。
'【注意】29日以降で存在しない場合は月末の日を返します。
Function zsPrevMonth(ByVal 日付) As Date
  zsPrevMonth = DateAdd("m", -1, 日付)
End Function

' 指定した日付の次月の日付を返します。
'【注意】29日以降で存在しない場合は月末の日を返します。
Function zsNextMonth(ByVal 日付) As Date
  zsNextMonth = DateAdd("m", 1, 日付)
End Function

' 指定した日付の前年の日付を返します。
'【注意】29日以降で存在しない場合は月末の日を返します。
Function zsPrevYear(ByVal 日付) As Date
  zsPrevYear = DateAdd("yyyy", -1, 日付)
End Function

' 指定した日付の来年の日付を返します。
'【注意】29日以降で存在しない場合は月末の日を返します。
Function zsNextYear(ByVal 日付) As Date
  zsNextYear = DateAdd("yyyy", 1, 日付)
End Function

' 終了日から開始日を引いた日数を取得します。Excel2013はDays関数があります。
Function zsDays(ByVal 終了日, ByVal 開始日) As Long
  zsDays = DateDiff("d", 開始日, 終了日)
End Function

' 去年の日付を返します。
Private Function zsLastYear() As Date
  zsLastYear = DateAdd("yyyy", -1, Date)
End Function

' 来年の日付を返します。
Private Function zsThisNextYear() As Date
  zsThisNextYear = DateAdd("yyyy", 1, Date)
End Function

' 昨日の日付を返します。
Private Function zsYesterday() As Date
  zsYesterday = DateAdd("d", -1, Date)
End Function

' 明日の日付を返します。
Private Function zsTomorrow() As Date
  zsTomorrow = DateAdd("d", 1, Date)
End Function

' 年が閏年かを判断します。(省略した場合は今年が閏年か判断します)
' 閏年とは400で割り切れるかあるいは、4で割り切れかつ100で割り切れない年です。
' 1900年は閏年ではありません。しかしExcelの仕様では1900年2月29日があります。この関数で1900年を閏年と扱いません。
' Excel は 1900 年が閏年であると誤った前提で
' https://support.microsoft.com/ja-jp/kb/214326
Private Function zsIsLeapYear(Optional ByValAs Variant) As Boolean ' 引数の年は年月日の日付でも良い
  Dim YYYY As Long ' 年

  If IsMissing(年) Then
      YYYY = Year(Date)
  ElseIf TypeName(年) = "Range" Then
    If TypeName(年.Cells(1).Value) = "Date" Then ' 複数のセルを選択している場合は最初のセルとする
      YYYY = Year(年.Cells(1).Value)
    ElseIf TypeName(年.Cells(1).Value) = "String" Then
      If Len(年.Cells(1).Value) < 5 Then
        YYYY = CInt(年.Cells(1).Value)
      Else
        YYYY = Year(DateValue(年.Cells(1).Value))
      End If
    Else
      YYYY = 年.Cells(1).Value
    End If
  ElseIf TypeName(年) = "Date" Then
    YYYY = Year(年)
  ElseIf TypeName(年) = "String" Then
    If Len(年) < 5 Then
      YYYY = CInt(年)
    Else
      YYYY = Year(DateValue(年))
    End If
  Else
    YYYY = 年
  End If
  
' 日付システム、日付形式、2 桁で表された西暦の解釈方法を変更する
' https://support.office.com/ja-JP/article/%E6%97%A5%E4%BB%98%E3%82%B7%E3%82%B9%E3%83%86%E3%83%A0%E3%80%81%E6%97%A5%E4%BB%98%E5%BD%A2%E5%BC%8F%E3%80%812-%E6%A1%81%E3%81%A7%E8%A1%A8%E3%81%95%E3%82%8C%E3%81%9F%E8%A5%BF%E6%9A%A6%E3%81%AE%E8%A7%A3%E9%87%88%E6%96%B9%E6%B3%95%E3%82%92%E5%A4%89%E6%9B%B4%E3%81%99%E3%82%8B-aaa2159b-4ae8-4651-8bce-d4707bc9fb9f
  If YYYY < 30 Then
    YYYY = YYYY + 2000 ' 29年以下は2000年以上とします。
  ElseIf YYYY < 100 Then
    YYYY = YYYY + 1900 ' 30年以上でかつ99年以下は1900年代とします。
  End If
  
  zsIsLeapYear = (YYYY Mod 400 = 0) Or ((YYYY Mod 4 = 0) And (YYYY Mod 100 <> 0))
End Function

' 和暦の日付の文字列を返します。(例.平成28年01月02日)
' DATESTRING関数は「関数の挿入」ダイアルログに表示されません。
Private Function zsDATESTRING(ByVal 日付 As Date) As String
  zsDATESTRING = Application.Evaluate("DATESTRING(""" & 日付 & """)")
End Function

' 日付からその年の春分の日を求めます。(簡易版)
Private Function zs春分の日(ByVal 日付 As Date) As Integer
  DimAs Long
  
  年 = Year(日付)
  zs春分の日 = Int(20.8431 + 0.242194 * (年 - 1980)) - Int((年 - 1980) / 4)
End Function

' 日付からその年の秋分の日を求めます。(簡易版)
Private Function zs秋分の日(ByVal 日付 As Date) As Integer
  DimAs Long
  
  年 = Year(日付)
  zs秋分の日 = Int(23.2488 + 0.242194 * (年 - 1980)) - Int((年 - 1980) / 4)
End Function
このページの上

zsその他
Option Explicit

' 銀行まるめの四捨五入です。偶数になるようにまるめます。zsRound(2.5)は2を返します。
Private Function zsRound(ByValAs Double, Optional ByVal 小数点の桁数 As Long = 0) As Variant
  zsRound = Round(値, 小数点の桁数)
End Function

' 計算式の結果を返します。例. (MAX(A1,A2)+2-1) * 4 / 2
Function zsEvaluate(ByVal 計算式 As String) As Variant
  zsEvaluate = Application.Evaluate(計算式)
End Function

' セルが数式かを返します。(True, False)
Private Function zsIsFormula(ByVal セル As Range) As Boolean
  zsIsFormula = セル.Cells(1, 1).HasFormula
End Function

' セルの数式を返します。
Function zsFormula(ByVal セル As Range) As String
  zsFormula = セル.Cells(1, 1).Formula
End Function

' セルの表示形式を返します。
Function zsNumberFormatLocal(ByVal セル As Range) As Variant
  Application.Volatile ' 自動再計算関数
  zsNumberFormatLocal = セル.Cells(1, 1).NumberFormatLocal
End Function

' セルの表示形式を返します。
Private Function zsNumberFormat(ByVal セル As Range) As Variant
  Application.Volatile ' 自動再計算関数
  zsNumberFormat = セル.Cells(1, 1).NumberFormat
End Function

' セルのフォントの名前を返します。
Function zsFontName(ByVal セル As Range) As Variant
  Application.Volatile ' 自動再計算関数
  zsFontName = セル.Cells(1, 1).Font.Name
End Function

' セルのフォントが太字かを返します。(True, False)
Function zsFontBold(ByVal セル As Range) As Boolean
  Application.Volatile ' 自動再計算関数
  zsFontBold = セル.Cells(1, 1).Font.Bold
End Function

' セルのフォントが斜字かを返します。(True, False)
Private Function zsFontItalic(ByVal セル As Range) As Boolean
  Application.Volatile ' 自動再計算関数
  zsFontItalic = セル.Cells(1, 1).Font.Italic
End Function

' セルがロックされているかを返します。(True, False)
' ExcelのCELL関数はロックが1,なしは0を返します。CELL("protect",セル)
Private Function zsProtect(ByVal セル As Range) As Boolean
  Application.Volatile ' 自動再計算関数
  zsProtect = セル.Cells(1, 1).Locked
End Function

' セルのフォントの色を返します。
Function zsFontColor(ByVal セル As Range) As Variant
  Application.Volatile ' 自動再計算関数
  zsFontColor = セル.Cells(1, 1).Font.Color
End Function

' セルのフォントの色パレットの番号を返します。
Private Function zsFontColorIndex(ByVal セル As Range) As Variant
  Application.Volatile ' 自動再計算関数
  zsFontColorIndex = セル.Cells(1, 1).Font.ColorIndex
End Function

' セルの背景色のパレットの番号を返します。
Function zsBackColor(ByVal セル As Range) As Variant
  Application.Volatile ' 自動再計算関数
  zsBackColor = セル.Cells(1, 1).Interior.ColorIndex
End Function

' RGBカラー値を返します。
' 赤, 緑, 青は0 〜 255 の範囲内の数値
'
' CVErr関数 セルのエラー値  https://msdn.microsoft.com/ja-jp/library/office/ff839168.aspx
'    定数       エラー番号  セルのエラー値
'    xlErrDiv0      2007    #DIV/0!
'    XlErrNA        2042    #N/A
'    xlErrName      2029    #NAME?
'    XlErrNull      2000    #NULL!
'    XlErrNum       2036    #NUM!
'    XlErrRef       2023    #REF!
'    XlErrValue     2015    #VALUE!
Function zsRGB(ByValAs Integer, ByValAs Integer, ByValAs Integer) As Variant
  If 赤 < 0 Or 赤 > 255 Then
    zsRGB = CVErr(xlErrValue)
  ElseIf 緑 < 0 Or 緑 > 255 Then
    zsRGB = CVErr(xlErrValue)
  ElseIf 青 < 0 Or 青 > 255 Then
    zsRGB = CVErr(xlErrValue)
  Else
    zsRGB = RGB(赤, 緑, 青)
  End If
End Function

' 指定したセルの範囲で条件付き書式が含まれているか取得します。
Private Function zsIsFormatConditions(ByVal セル As Range) As Boolean
  zsIsFormatConditions = セル.FormatConditions.Count > 0
End Function

' 指定したセルの範囲でデータの入力規則が含まれているか取得します。
Private Function zsIsValidation(ByVal セル As Range) As Boolean
  Dim r As Range
  
  Err.Clear
  On Error Resume Next
  Set r = セル.SpecialCells(xlCellTypeAllValidation)
  
  If Err.Number > 0 Then
    zsIsValidation = False
    Err.Clear
  Else
    zsIsValidation = Not Application.Intersect(セル, r) Is Nothing
  End If
  
  On Error GoTo 0
End Function

' 指定したセルのスタイルの名前を取得します。(複数のセルを指定した場合は左上の1つのセルを対象)
Private Function zsStyleName(ByVal セル As Range) As String
  zsStyleName = セル.Cells(1, 1).Style.Name
End Function

' アドイン フォルダ名を返します。
Function zsUserLibraryPath() As String
  Application.Volatile ' 自動再計算関数
  zsUserLibraryPath = Application.UserLibraryPath
End Function

' テンプレート フォルダ名を返します。
Function zsTemplatesPath() As String
  Application.Volatile ' 自動再計算関数
  zsTemplatesPath = Application.TemplatesPath
End Function

' スタートアップ フォルダ名を返します。
Function zsStartupPath() As String
  Application.Volatile ' 自動再計算関数
  zsStartupPath = Application.StartupPath
End Function

' OSの環境変数と関連付けられている文字列を返します。
' Environ({envstring | number})
' envstring・・・省略可能。環境変数の名前を含む文字列式。
' Number・・・省略可能。環境文字列テーブル内の環境文字列の数値順序に対応する数式。number引数には任意の数式を使用できますが、整数に丸められてから評価されます。
Function zsEnviron(ByVal 環境変数 As Variant) As String
  Application.Volatile ' 自動再計算関数
  zsEnviron = Environ(環境変数)
End Function

' シートの数を返します。(ワークシート、グラフ、MS Excelダイアログ、Excel 4.0マクロを含みます。)
Private Function zsSheetCount() As Long
  zsSheetCount = ActiveWorkbook.Sheets.Count
End Function

' ワーク シートの数を返します。
Private Function zsWorksheetCount() As Long
  zsWorksheetCount = ActiveWorkbook.Worksheets.Count
End Function

' センチメートル単位の数値を、ポイント単位に変換します。(1mmは 28.3464566929134ポイント、1ポイントは、0.35mm)
Private Function zsCentimetersToPoints(ByVal Centimeters As Double) As Double
  zsCentimetersToPoints = Application.CentimetersToPoints(Centimeters)
End Function

' インチ単位の数値をポイント単位に変換します。(1インチは72ポイント)
Private Function zsInchesToPoints(ByVal Inches As Double) As Double
  zsInchesToPoints = Application.InchesToPoints(Inches)
End Function

' 空の文字列を返します。(引数にコメントを記載できます)
Private Function zsC(ByVal Arg As Variant) As String
  zsC = ""
End Function

' 0の値を返します。(引数にコメントを記載できます)エクセルのN関数でもできますが...
Private Function zs0(ByVal Arg As Variant) As Integer
  zs0 = 0
End Function

' セルのコメントのテキストを取得します。(複数のセルを指定した場合は、左上のせるのみ対象とします)
Private Function zsCommentText(ByVal セル As Range) As String
  If セル.Cells(1, 1).Comment Is Nothing Then
    zsCommentText = ""
  Else
    zsCommentText = セル.Cells(1, 1).Comment.Text
  End If
End Function
このページの上