Help us understand the problem. What is going on with this article?

VBA便利かもしれない関数群

More than 1 year has passed since last update.

前職でよくVBAを使う場面があって、いろいろ便利かもしれない関数群が溜まっていたので公開しちゃおう。大したものはございません。

CommonModule.bas
Attribute VB_Name = "CommonModule"
Option Explicit
'---------------------------------------------------------------------------------------------------------------
'[プログラム名] 共通モジュール
'[処理概要]     汎用的に使用できる関数群を定義する
'[作成者]       
'[作成日]       
'[更新日]       
'[備考]
'[動作確認]     Excel2003
'---------------------------------------------------------------------------------------------------------------

'---------------------------------------------------------------------------------------------------------------
'共通変数
'---------------------------------------------------------------------------------------------------------------
Public mcrDir As String                                                            'マクロがあるディレクトリパス
Public fso As Object                                                               'ファイルシステムオブジェクト
Public saveStatusBarFlag As Boolean                                                'ステータスバー表示フラグ保存用

'---------------------------------------------------------------------------------------------------------------
'[機能名] 共通初期処理
'[返り値] 無し
'[引数]   無し
'[概要]   共通モジュール用の初期処理をする
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Sub commonInit()

    Set fso = CreateObject("Scripting.FileSystemObject")

    mcrDir = fso.GetParentFolderName(ThisWorkbook.FullName)

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] CSV配列変換
'[返り値] 無し
'[引数]   textLine : CSVファイルから読み込んだ行データ
'[概要]   CSV行データを配列として取得する
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function getCsv(ByVal textLine As String) As String()

    Dim csv() As String

    textLine = Replace(textLine, """", "")
    csv() = Split(textLine, ",")

    getCsv = csv

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 日付スラッシュ付与
'[返り値] スラッシュ付与後の日付文字列
'[引数]   dateStr : 対象日付文字列
'[概要]   日付文字列にスラッシュを付与する
'[備考]   対象日付文字列にはYYYYMM形式かYYYYMMDD形式のみ対応
'---------------------------------------------------------------------------------------------------------------
Public Function slashDate(dateStr As String) As String

    Dim strLen As Integer

    strLen = Len(dateStr)

    Select Case strLen
    Case 6
        slashDate = Left(dateStr, 4) & "/" & Right(dateStr, 2)
    Case 8
        slashDate = Left(dateStr, 4) & "/" & Mid(dateStr, 5, 2) & "/" & Right(dateStr, 2)
    Case Else
        slashDate = dateStr
    End Select

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] ファイルパス取得
'[返り値] ファイルパス
'         ダイアログでキャンセルされた場合はブランク
'[引数]   title        : ダイアログタイトル(省略可)
'         initialPath  : 初期表示パス(省略可)
'         filterName   : ファイルの種類名(例:Excelブック)
'         filterSuffix : ファイルの拡張子(例:"*.xls; *.xlsx; *.xlsm")
'[概要]   ファイルダイアログを使用してファイルパスを取得する
'[備考]   複数選択未対応
'---------------------------------------------------------------------------------------------------------------
Public Function getFilePath(Optional title As String = "", Optional InitialFileName As String = "", Optional filterName As String = "", Optional filterSuffix As String = "") As String

    Dim fileDlg As Office.FileDialog
    Dim filePath As String
    Dim result As Integer

    filePath = ""

    'ファイルダイアログオブジェクト生成
    Set fileDlg = Application.FileDialog(msoFileDialogFilePicker)

    'ダイアログタイトル設定
    If title <> "" Then
        fileDlg.title = title
    End If

    '初期表示パス設定
    If InitialFileName <> "" Then
        fileDlg.InitialFileName = InitialFileName
    End If

    'フィルター設定
    If filterName <> "" And filterSuffix <> "" Then
        fileDlg.Filters.Clear
        fileDlg.Filters.Add filterName, filterSuffix
    Else
        fileDlg.Filters.Clear
    End If

    '複数選択設定
    fileDlg.AllowMultiSelect = False

    'ファイルダイアログ表示
    result = fileDlg.Show()

    'ファイルダイアログ表示結果判定
    If result = -1 Then
      filePath = fileDlg.SelectedItems(1)
    End If

    getFilePath = filePath

End Function
'---------------------------------------------------------------------------------------------------------------
'[機能名] ファイルパス取得(Excel2000対応)
'[返り値] ファイルパス
'         ダイアログでキャンセルされた場合はブランク
'[引数]   curDir       : 初期表示フォルダパス
'         filer        : ファイルフィルター文字列(例:"Microsoft Excelブック,*.xls;*.xlsx")
'[概要]   ファイルダイアログを使用してファイルパスを取得する
'[備考]   複数選択未対応
'---------------------------------------------------------------------------------------------------------------
Public Function getFilePath2(curDir As String, filter As String) As String

    Dim filePath As Variant

    ChDir curDir
    filePath = Application.GetOpenFilename(filter)

    If VarType(filePath) = vbBoolean Then
        getFilePath2 = ""
    Else
        getFilePath2 = filePath
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] シート存在チェック
'[返り値] true  : 存在する
'         false : 存在しない
'[引数]   book      : チェック対象ブックオブジェクト
'         sheetName : チェック対象シート名
'[概要]   指定した名前のシートが存在するかチェックする
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function existSheet(book As Workbook, sheetName As String) As Boolean

    Dim i As Integer

    existSheet = False

    For i = 1 To book.Sheets.Count
        If book.Sheets(i).name = sheetName Then
            existSheet = True
            Exit For
        End If
    Next

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 罫線設定
'[返り値] 無し
'[引数]   sheet    : シートオブジェクト
'         startRow : 罫線設定範囲の開始行番号
'         startCol : 罫線設定範囲の開始列番号
'         endRow   : 罫線設定範囲の終了行番号
'         endCol   : 罫線設定範囲の終了列番号
'[概要]   指定した範囲に格子状の罫線を設定する
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Sub setGridLine(sheet As Worksheet, startRow, startCol, endRow, endCol)

    sheet.Range(sheet.Cells(startRow, startCol), sheet.Cells(endRow, endCol)).Borders.LineStyle = xlContinuous

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] A1形式の相対アドレス取得
'[返り値] A1形式の相対アドレス
'[引数]   cell : 取得対象セルオブジェクト
'[概要]   指定したセルのA1形式の相対アドレスを取得する
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function getAddress(cell As Range) As String

    getAddress = cell.Address(RowAbsolute:=False, ColumnAbsolute:=False)

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] SUBTOTAL関数セット
'[返り値] 無し
'[引数]   targetCell : 関数セット対象セルオブジェクト
'         startCell  : 範囲開始セルオブジェクト
'         endCell    : 範囲終了セルオブジェクト
'[概要]   指定したセルにSUBTOTAL関数をセットする
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Sub setSubTotal(targetCell As Range, startCell As Range, endCell As Range)

    targetCell.formula = "=SUBTOTAL(9," & getAddress(startCell) & ":" & getAddress(endCell) & ")"

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] 最大行数取得
'[返り値] 最大行数
'[引数]   sheet : 取得対象シート
'[概要]   指定したシートの最大行数を取得する
'[備考]   参考:http://www.niji.or.jp/home/toru/notes/8.html
'---------------------------------------------------------------------------------------------------------------
Public Function getMaxRow(sheet As Worksheet) As Long

    getMaxRow = sheet.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).row

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 最大列数取得
'[返り値] 最大列数
'[引数]   sheet : 取得対象シート
'[概要]   指定したシートの最大列数を取得する
'[備考]   参考:http://www.niji.or.jp/home/toru/notes/8.html
'---------------------------------------------------------------------------------------------------------------
Public Function getMaxCol(sheet As Worksheet) As Long

    getMaxCol = sheet.UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 配列コンパクト化
'[返り値] 配列
'[引数]   ary : 対象配列
'[概要]   配列から空文字要素を削除する
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Function arrayCompact(ary As Variant) As Variant

    Dim afterAry() As Variant
    Dim v As Variant
    Dim idx As Long

    idx = 0
    For Each v In ary
        If v <> "" Then
            ReDim Preserve afterAry(idx)
            afterAry(idx) = v
            idx = idx + 1
        End If
    Next v

    arrayCompact = afterAry

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 全角→半角変換(数字、ハイフンのみ)
'[返り値] 半角変換後文字列
'[引数]   str : 対象文字列
'[概要]   引数の文字列に含まれる全角の数字、ハイフンを半角に変換する
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Function ascOnlyNum(str As String) As String

    Dim idx As Integer
    Dim char As String
    Dim ansData As String

    ansData = ""
    For idx = 1 To Len(str)

        char = Mid(str, idx, 1)

        If char Like "[0-9]" Or char Like "-" Then
            ansData = ansData & StrConv(char, vbNarrow)
        Else
            ansData = ansData & char
        End If

    Next idx

    ascOnlyNum = ansData

End Function


'---------------------------------------------------------------------------------------------------------------
'[機能名] 初期シート削除
'[返り値] 無し
'[引数]   book : 対象ブックオブジェクト
'[概要]   引数のブックから初期シート(Sheet1,Sheet2,Sheet3)があれば削除する
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Sub deleteDefaultSheet(book As Workbook)

    Dim sheetName As String
    Dim i As Integer

    For i = 1 To 3

        sheetName = "Sheet" & i

        Application.DisplayAlerts = False

        If existSheet(book, sheetName) Then
            book.Sheets(sheetName).Delete
        End If

        Application.DisplayAlerts = True

    Next i

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] 文字列パディング
'[返り値] 加工後文字列
'[引数]   beforStr : 加工対象文字列、leng : 加工後文字列のバイト数
'         paddingStr : パディング文字、justType : 右詰めか左詰めか("right" or "left")
'[概要]   文字列の前後を指定の文字で埋める
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function paddingString(beforeStr As String, leng As Integer, paddingStr As String, justType As String) As String

    Dim i As Integer
    Dim tmpStr As String
    Dim subLeng As Integer
    Dim paddingStrLeng As Integer
    Dim paddingStrCnt As Integer
    Dim amari As Integer

    '加工対象文字列の前後の全半角スペース除去
    tmpStr = Trim(beforeStr)

    'パディングするバイト数算出
    subLeng = leng - LenB(StrConv(tmpStr, vbFromUnicode))

    'パディング文字のバイト数算出
    paddingStrLeng = LenB(StrConv(paddingStr, vbFromUnicode))

    '必要パディング文字数算出
    paddingStrCnt = subLeng / paddingStrLeng

    '必要パディング数算出で割り切れない場合はエラー
    amari = subLeng Mod paddingStrLeng

    If amari <> 0 Then
        Err.Raise 513, , "paddingString関数エラー" & Chr(13) & _
                            "空き文字列バイト数(" & subLeng & ")をパディング文字バイト数(" & paddingStrLeng & ")で割りきれませんでした。"
    End If

    'パディング処理
    For i = 1 To paddingStrCnt
        Select Case justType
        Case "left"
            tmpStr = tmpStr & paddingStr
        Case "right"
            tmpStr = paddingStr & tmpStr
        Case Else
            Err.Raise 514, , "paddingString関数エラー" & Chr(13) & _
                                "引数:justTypeの指定が不正です。"
        End Select
    Next i

    paddingString = tmpStr

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 範囲文字列抽出
'[返り値] 抽出文字列
'[引数]   str : 対象文字列、startStr : 抽出開始文字、endStr : 抽出終了文字
'[概要]   抽出開始文字~抽出終了文字の間の文字列を返す
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function getRangeString(str As String, startStr As String, endStr As String) As String

    Dim strPos As Integer
    Dim endPos As Integer
    Dim strLen As Integer

    getRangeString = ""

    strPos = InStr(str, startStr)
    endPos = InStr(str, endStr)

    If strPos = 0 Or endPos = 0 Then
        getRangeString = ""
    Else
        strLen = endPos - strPos - 1
        getRangeString = Mid(str, strPos + 1, strLen)
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 文字列日付変換
'[返り値] 変換日付
'[引数]   str : 対象文字列
'[概要]   DATEVALUE関数と同じだが、引数が空文字の場合に、空文字を返す
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function datevalue2(str As String) As Variant

    If str = "" Then
        datevalue2 = ""
    Else
        datevalue2 = DateValue(str)
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 稼働日計算
'[返り値] 計算後の日付文字列
'[引数]   omitDaySheetName    : 非稼働日リストシート名
'         omitDayRange        : 稼働日から除外する日付を入力してあるセル範囲(例 A1:A144)
'         baseDay             : 計算基準日(YYYY/MM/DD形式)
'         dayCount            : 稼動日数
'[概要]   WORKDAY関数にチェック機能を組み込んだ関数
'[備考]   要非稼働日リストシート(非稼働日を降順に縦に列挙したデータが必要)
'---------------------------------------------------------------------------------------------------------------
Public Function workday2(omitDaySheetName As String, omitDayRange As String, baseDay As String, dayCount As Integer) As String

    Dim str As String
    Dim res As Variant
    Dim ary() As String

    If baseDay = "" Then
        workday2 = ""
        Exit Function
    End If

    '非稼働日リストシート存在チェック
    If Not existSheet(ThisWorkbook, omitDaySheetName) Then
        MsgBox omitDaySheetName & "シートが存在しないため、稼働日計算ができません。"
        workday2 = "稼働日計算エラー"
        Exit Function
    End If

    '非稼働日リストチェック
    ary = Split(omitDayRange, ":")
    If Date > ThisWorkbook.Sheets(omitDaySheetName).Range(ary(1)) Then

        MsgBox "「現在日付 > " & omitDaySheetName & "シートの最終日」になりました。" & Chr(13) & _
               omitDaySheetName & "シートを最新にして下さい。"
        workday2 = "稼働日計算エラー"
        Exit Function

    End If

    '稼働日計算
    AddIns("分析ツール").Installed = True
    str = "WORKDAY(""" & baseDay & """," & dayCount & "," & omitDaySheetName & "!" & omitDayRange & ")"
    workday2 = Format(Evaluate(str), "YYYY/MM/DD")

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 稼働日計算
'[返り値] 計算後の日付文字列
'[引数]   calendarSheetName   : 稼働日リストシート名
'         baseDay             : 計算基準日(YYYY/MM/DD形式)
'         dayCount            : 稼動日数
'[概要]   カレンダーマスタを元に稼動日計算を行う
'[備考]   要稼働日リストシート
'---------------------------------------------------------------------------------------------------------------
Public Function workday3(calendarSheetName As String, baseDay As String, dayCount As Integer) As String

    Dim row As Long
    Dim maxRow As Long
    Dim calendarSheet As Worksheet
    Dim baseDayStr As String

    Dim calCnt As Integer

    If baseDay = "" Then
        workday3 = ""
        Exit Function
    End If

    '稼働日リストシート存在チェック
    If Not existSheet(ThisWorkbook, calendarSheetName) Then
        MsgBox calendarSheetName & "シートが存在しないため、稼働日計算ができません。"
        Exit Function
    End If

    Set calendarSheet = ThisWorkbook.Sheets(calendarSheetName)
    maxRow = getMaxRow(calendarSheet)
    baseDayStr = Format(baseDay, "YYYYMMDD")

    For row = 1 To maxRow
        If calendarSheet.Cells(row, 1).Value = baseDayStr Then
            Exit For
        End If
    Next row

    calCnt = 0
    If dayCount >= 0 Then
        For row = row + 1 To maxRow
            If calendarSheet.Cells(row, 2).Value = 0 Or calendarSheet.Cells(row, 2).Value = 2 Then
                calCnt = calCnt + 1
            End If

            If dayCount = calCnt Then
                workday3 = slashDate(calendarSheet.Cells(row, 1).Value)
                Exit Function
            End If
        Next row
    Else
        For row = row - 1 To 1 Step -1
            If calendarSheet.Cells(row, 2).Value = 0 Or calendarSheet.Cells(row, 2).Value = 2 Then
                calCnt = calCnt - 1
            End If

            If dayCount = calCnt Then
                workday3 = slashDate(calendarSheet.Cells(row, 1).Value)
                Exit Function
            End If
        Next row
    End If

    workday3 = "稼動日計算エラー"

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 稼働日判定
'[返り値] 1 : 稼動日、 0 : 非稼動日、-1 : 判定不能
'[引数]   calendarSheetName   : 稼働日リストシート名
'         targetDay           : 対象日
'[概要]   カレンダーマスタを元に稼動日判定を行う
'[備考]   要稼働日リストシート
'---------------------------------------------------------------------------------------------------------------
Public Function isWorkday(calendarSheetName As String, targetDay As String) As Integer

    Dim row As Long
    Dim maxRow As Long
    Dim calendarSheet As Worksheet
    Dim targetDayStr As String
    Dim calCnt As Integer
    Dim hitFlag As Boolean

    hitFlag = False

    '稼働日リストシート存在チェック
    If Not existSheet(ThisWorkbook, calendarSheetName) Then

        MsgBox calendarSheetName & "シートが存在しないため、稼働日判定ができません。"
        Exit Function

    End If

    Set calendarSheet = ThisWorkbook.Sheets(calendarSheetName)
    maxRow = getMaxRow(calendarSheet)
    targetDayStr = Format(targetDay, "YYYYMMDD")

    For row = 1 To maxRow
        If calendarSheet.Cells(row, 1).Value = targetDayStr Then
            hitFlag = True
            If calendarSheet.Cells(row, 2).Value = 0 Or calendarSheet.Cells(row, 2).Value = 2 Then
                isWorkday = 1
            Else
                isWorkday = 0
            End If
            Exit Function
        End If
    Next row

    If Not hitFlag Then
        isWorkday = -1
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] EXCELバージョン別拡張子取得
'[返り値] 拡張子文字列
'[引数]   無し
'[概要]   マクロを実行するEXCELバージョン別の拡張子を返す
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function getSuffixExcelVersion() As String

    Dim suffix As String

    If CInt(Application.Version) > 12 Then
        suffix = "xlsx"
    Else
        suffix = "xls"
    End If

    getSuffixExcelVersion = suffix

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 最近・最古日付取得
'[返り値] 日付
'[引数]   dateList() : 日付文字列配列、mode : 最近ならnew、最古ならoldを指定
'[概要]   引数の日付文字列配列から、最近または最古の日付を返す
'[備考]   日付文字列は2014/04/15や2014-04-15で指定。20140415は不可。
'---------------------------------------------------------------------------------------------------------------
Public Function getDateEdge(dateList() As String, mode As String) As Date

    Dim d As Variant
    Dim serialList() As Long
    Dim idx As Integer

    idx = 0
    For Each d In dateList

        ReDim Preserve serialList(idx)
        serialList(idx) = DateValue(d)
        idx = idx + 1

    Next d

    Select Case mode
    Case "new"
        getDateEdge = CDate(Application.Max(serialList))
    Case "old"
        getDateEdge = CDate(Application.Min(serialList))
    Case Else
        MsgBox "getDateEdge関数エラー"
        Exit Function
    End Select

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 配列要素数取得
'[返り値] 配列の要素数
'[引数]   ary : 配列
'[概要]   引数の配列の要素数を返す。引数で指定した配列が定義されていない場合は、0を返す。
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function getArraySize(ary As Variant) As Integer

    If Sgn(ary) <> 0 Then
        getArraySize = UBound(ary)
    Else
        getArraySize = 0
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] ステータスバー表示制御
'[返り値] 無し
'[引数]   mode : on(ステータスバー表示)、set(statusStrに設定した文字列を表示)、off(ステータスバー表示設定にし、表示内容を規定値に戻す)
'         statusStr : ステータスバーに表示させたい文字列
'[概要]   引数参照
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Sub controlStatusBar(mode As String, Optional statusStr As String)

    Select Case mode
    Case "on"
        saveStatusBarFlag = Application.DisplayStatusBar
        Application.DisplayStatusBar = True
    Case "set"
        Application.StatusBar = statusStr
    Case "off"
        Application.DisplayStatusBar = saveStatusBarFlag
        Application.StatusBar = False
    End Select

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] 日付6桁→8桁変換
'[返り値] 変換後日付
'[引数]   yymmdd : YYMMDD形式の日付数字
'[概要]   西暦下2桁+MMDD形式の日付数字をYYYYMMDD形式に変換する
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function date6to8(yymmdd As Long) As Long

    Dim yymmddStr As String

    yymmddStr = CStr(yymmdd)

    If CInt(Left(yymmddStr, 2)) > 50 Then
        date6to8 = yymmdd + 19000000
    Else
        date6to8 = yymmdd + 20000000
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 全半角混在チェック
'[返り値] ブランク:チェック対象文字が空、"ZEN":全角のみ、"HAN":半角のみ、"ZENHAN":全半角混在
'[引数]   strUnicode:チェック対象文字列
'[概要]   チェック対象文字列の全半角文字存在チェック
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function checkDblByte(strUnicode As String) As String

    Dim strANSI    As String
    Dim myLen      As Integer
    Dim myLenB     As Integer

    If strUnicode = "" Then
        checkDblByte = ""
        Exit Function
    End If

    'EXCEL97以降 文字をUnicodeで扱うようになり、全て2byte
    'になったので、ANSIに変換する
    strANSI = StrConv(strUnicode, vbFromUnicode)

    'チェック対象文字列の文字数取得
    myLen = Len(strUnicode)

    'チェック対象文字列(ANSI)のバイト数取得
    myLenB = LenB(strANSI)

    '全半角判定
    If myLen * 2 = myLenB Then
        checkDblByte = "ZEN"
    ElseIf myLen = myLenB Then
        checkDblByte = "HAN"
    Else
        checkDblByte = "ZENHAN"
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] シートペースト&式除去
'[返り値] ペースト先ブック
'[引数]   book : ペースト元ブック、sheetNameList : ペースト元シート名配列、mode : ペースト時、move or copy
'[概要]   指定したブックのシートを、新しいブックにコピーor移動し、さらに全式を除去
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function pasteSheet(book As Workbook, sheetNameList() As String, mode As String) As Workbook

    Dim newBook As Workbook
    Dim sheetName As Variant

    Select Case mode
    Case "copy"
        book.Sheets(sheetNameList).Copy
    Case "move"
        book.Sheets(sheetNameList).Move
    Case Else
        MsgBox "pasteSheet関数エラー"
        Exit Function
    End Select

    Set newBook = ActiveWorkbook

    For Each sheetName In sheetNameList
        newBook.Sheets(sheetName).Activate
        newBook.Sheets(sheetName).Cells.Select
        Selection.Copy
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=False
    Next sheetName

    Set pasteSheet = newBook

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] リスト名定義
'[返り値] 無し
'[引数]   book : リスト名定義対象ブック、targetRange : 定義範囲セル、name : リスト名
'[概要]   リスト名を定義する
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Sub setNameDef(book As Workbook, targetRange As Range, name As String)

    On Error Resume Next

    book.Names(name).Delete
    book.Names.Add (name), RefersTo:=targetRange

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] 入力規則設定
'[返り値] 無し
'[引数]   targetRange : 規則設定範囲セル、validationListName : リスト名
'[概要]   入力規則を設定する
'[備考]   ボタンからクリックで当関数を使用するとaddメソッドでエラーになる。(仕様?)
'         回避するには、直前にどこかのセルをselectしておく必要有り。
'---------------------------------------------------------------------------------------------------------------
Public Sub setValidationList(targetRange As Range, validationListName As String)

    targetRange.Validation.Delete
    targetRange.Validation.Add Type:=xlValidateList, Formula1:="=" & validationListName

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] 指定したシートのセルから、下方向へ最初の空白行前の行番号取得
'[返り値] 行番号
'[引数]   開始セル
'[概要]
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Function getBottomRow(sheet As Worksheet, strCell As Range) As Long

    Dim row As Long
    Dim col As Integer

    row = strCell.row
    col = strCell.Column

    If sheet.Cells(row + 1, col).Value = "" Then
        getBottomRow = row
    Else
        getBottomRow = strCell.End(xlDown).row
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] うるう年判定
'[返り値] true : うるう年、false : うるう年でない
'[引数]   年(4桁)
'[概要]
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Function IsLeapYear(年 As Integer) As Boolean
'機能:引数で与えられた年がうるう年かどうか判定するユーザー定義関数
'引数:年
'うるう年のときはTrueを返す

   Dim Leap As Boolean

    If ((年 Mod 4) = 0 And (年 Mod 100) <> 0 Or (年 Mod 400) = 0) Then
        Leap = True
    Else
        Leap = False
    End If

    IsLeapYear = Leap

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 引数のエクセルが開かれているかどうか
'[返り値] true : 開かれている、false : 開かれていない
'[引数]   対象ファイルパス
'[概要]
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Function checkOpenExcel(filePath As String) As Boolean

    Dim fileNo As Integer

    fileNo = FreeFile

    On Error Resume Next
    Open filePath For Append As #fileNo
    Close #fileNo

    If Err.Number > 0 Then
        checkOpenExcel = True
    Else
        checkOpenExcel = False
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 引数のシートからキー名の設定値を取得する
'[返り値] 設定値(設定キー名が見つからない場合はブランク)
'[引数]   key : 設定キー名、sheet : 設定シート、settingRange : 設定記載範囲、 valueColumn : キーに対して値が記載されている列番号
'[概要]
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Function getSetting(key As String, sheet As Worksheet, Optional settingRange As String = "A:B", Optional valueColumn As Integer = 2) As Variant

    On Error Resume Next
    getSetting = Application.WorksheetFunction.VLookup(key, sheet.Range(settingRange), valueColumn, 0)
    If Err.Number = 1004 Then
        getSetting = ""
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 引数のプロセス名が存在するかチェックする
'[返り値] true : 存在する、 false : 存在しない
'[引数]   processName : チェックするプロセス名(大文字・小文字関係無し)
'[概要]
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Function TaskExists(processName As String) As Boolean

    Dim Locator: Set Locator = CreateObject("WbemScripting.SWbemLocator")
    Dim Server: Set Server = Locator.ConnectServer
    Dim objSet: Set objSet = Server.ExecQuery("Select * From Win32_Process")
    Dim obj

    For Each obj In objSet
        '比較は小文字に変換して行う。(大文字・小文字の違いを無視させる)
        If LCase(obj.Caption) = LCase(processName) Then
            TaskExists = True
            Exit Function
        End If
    Next

    TaskExists = False

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 引数のパスをWindowsの関連付けで開く
'[返り値] 無し
'[引数]   path : ファイルパス , windowsStyle : 起動時のウインドウスタイル
'[概要]
'[備考]   起動時のウインドウスタイルは下記参照
'         https://msdn.microsoft.com/ja-jp/library/cc364421.aspx?f=255&MSPPError=-2147217396
'---------------------------------------------------------------------------------------------------------------
Public Sub runApp(path As String, windowStyle As Integer)

    Dim WSH

    Set WSH = CreateObject("Wscript.Shell")
    WSH.Run """" & path & """", windowStyle
    Set WSH = Nothing

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] カンマ変換
'[返り値] カンマ変換後文字列
'[引数]   str : 変換対象文字列、mode : 半角→全角なら"to全角"、その逆なら"to半角"
'[概要]   カンマを全角/半角変換する
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function convComma(str As String, mode As String) As String

    Select Case mode
    Case "to全角"
        convComma = Replace(str, ",", ",")
    Case "to半角"
        convComma = Replace(str, ",", ",")
    Case Else
        convComma = str
    End Select

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 式コピー
'[返り値] 無し
'[引数]   sheet : 対象シート、startRow : コピー開始行番号、 startCol : コピー開始列番号
'                             endRow   : コピー終了行番号、 endCol   : コピー終了列番号、 formula : コピー対象式文字列
'[概要]   コピー開始行・列番号のセルからコピー終了行・列番号のセルまでを式コピーする
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Sub copyFormula(sheet As Worksheet, startRow As Long, startCol As Integer, endRow As Long, endCol As Integer, formula As String)

    Dim row As Long
    Dim col As Integer

    row = endRow - startRow + 1
    col = endCol - startCol + 1
    sheet.Cells(startRow, startCol).Resize(row, col).formula = formula

End Sub

'---------------------------------------------------------------------------------------------------------------
'[機能名] ダブルクォーテーション存在チェック
'[返り値] true : 存在する、false : 存在しない
'[引数]   str:チェック対象文字列
'[概要]   チェック対象文字列のダブルクォーテーション存在チェック
'[備考]   無し
'---------------------------------------------------------------------------------------------------------------
Public Function checkDblQuote(str As String) As Boolean

    checkDblQuote = False

    If InStr(1, str, """") > 0 Then
        checkDblQuote = True
    End If

End Function

'---------------------------------------------------------------------------------------------------------------
'[機能名] 配列が定義されているかチェックする
'[返り値] true: 定義されている、false:定義されていない
'[引数]   配列
'[概要]   配列が定義されているかチェックする
'[備考]
'---------------------------------------------------------------------------------------------------------------
Public Function checkArray(ary As Variant) As Boolean

    On Error Resume Next

    Dim tmp As Long

    tmp = UBound(ary)

    If Err.Number = 9 Then
        checkArray = False
    Else
        checkArray = True
    End If

End Function
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away
Comments
Sign up for free and join this conversation.
If you already have a Qiita account
Why do not you register as a user and use Qiita more conveniently?
You need to log in to use this function. Qiita can be used more conveniently after logging in.
You seem to be reading articles frequently this month. Qiita can be used more conveniently after logging in.
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away