Menu.bas
Attribute VB_Name = "M99_myFunction"
'★index
'外部からの呼び出し方
'CallFncName = "fnc_ColumnIdx2Name"
'CallFunPath = "'C:\Users\10035690229\AppData\Roaming\Microsoft\AddIns\Menu.xlam'!"
'Dummy = Application.Run(CallFunPath & CallFncName, hikisu)

'1 fnc_insrChar：文字列の中に文字を挿入
'  対象に文字列を挿入したあとの文字列 = fnc_insrChar(対象の文字, 挿入したい文字, 挿入する位置)

'2 fnc_readFile：テキストファイルを配列に格納
'  1次元配列 = fnc_readFile(ファイルパス)

'3 fnc_Array_MergeTo2D：二つの一次元配列を二次元配列にする(横方向)
'  二次元配列 = fnc_Array_MergeTo2D(一次元配列, 一次元配列)

'4 fnc_MergeArray_Column：二次元配列に一次元配列をマージする(横方向)
'  二次元配列 = fnc_MergeArray_Column(二次元配列, 一次元配列)

'5 fnc_CopyCheck：フォルダ1の中身がフォルダ2に全て入っおり、更新日付が完全一致するか確認(=コピペ成功してるか確認)
'  チェック結果(Boolean) = fnc_CopyCheck(フォルダパス1, フォルダパス2)

'6 fnc_ColumnIdx2Name：数字→列番号に変換
'  列番号 = fnc_ColumnIdx2Name(数字)

'7 fnc_arrTranspose：二次元配列の行列を入れ替える
'  testarr = fnc_arrTranspose(testarr)

'8 fnc_ArraySizeChange：二次元配列の一次元目をReDimする
'  二次元配列 = fnc_ArraySizeChange(二次元配列, ReDimする数字)

'9 fnc_MakeFolder：指定したパスに新規フォルダを作成する。名前がかぶってたら"-n"を最後につける。
'  sPath = fnc_MakeFolder(ActiveWorkbook.Path, Format(Date, "yyyymmdd"))

'10 fnc_DeleteSheet：引数名のシートを削除する。
'   fnc_DeleteSheet("削除するシート名")

'11 fnc_NotSleep：スリープ対策
'   fnc_NotSleep

'12 fnc_SaveLog：ログ保存しながらスリープ対策
'   fnc_SaveLog

'13 fnc_SelectFileInExplorer：指定したファイルをエクスプローラーで開いて選択する
'   fnc_SelectFileInExplorer("C:\work\559D\設計資料(途中)\HG処理の流れ.xlsx")

'14 fnc_OpenFolder：フォルダを開く
'   fnc_OpenFolder("C:\work\559D")

'15 fnc_DelFolder：フォルダを削除する
'   fnc_DelFolder("C:\work\559D")

'16 fnc_Un7zip：7-Zipでzipファイルを解凍する
'   fnc_Un7zip("C:\work\test.zip","C:\work")

'17 fnc_ExistFileCheck：ファイルが存在するか確認
'   If fnc_ExistFileCheck("ファイルパス") Then MsgBox "存在する"

'18 fnc_ReadOnlyCheck：読み取り専用か確認
'   If fnc_ReadOnlyCheck("ファイルパス") Then MsgBox "読み取り専用"

'19 fnc_OpenText：メモ帳でテキストファイルを開く
'   fnc_OpenText("フルパス")

'20 fnc_DelBracket：[]と[]の中の文字を削除
'   myStr = fnc_DelBracket(myStr, "[", "]")

'21 fnc_ClipBoardSave：テキストをクリップボードにコピー(文字化け対策済)
'   Call fnc_ClipBoardSave("文字")

'22 fnc_ReplaceStr：半角記号を全角に変換する(ファイル名NG文字対策)
'   str = fnc_ReplaceStr("文字")

'23 fnc_rc：シートの最終行と最終列を取得
'   Call fnc_rc(r,c,"シート名(省略可能)")

'24 fnc_ExistsSheet：シートが存在するか確認する
'   If fnc_ExistsSheet("シート名") = False Then MsgBox "存在しない"

'97 fnc_StatusBar：進行状況表示
'   Call fnc_StatusBar(分子, 分母)

'98 fnc_st：スタート処理
'   Call fnc_st

'99 fnc_end：スタート処理
'   Call fnc_end

'⑪用
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
'--------------------------------------------------
'指定した文字列を挿入する
'   引数
'       in_strInput :   対象の文字列
'       in_strChar :    挿入したい文字列
'       in_intPos :     挿入する位置
'   戻り値
'       対象に文字列を挿入したあとの文字列
'--------------------------------------------------
'例)対象に文字列を挿入したあとの文字列=fnc_insrChar(対象の文字,挿入したい文字,挿入する位置)
Public Function fnc_insrChar(in_strInput As String, _
  in_strChar As String, in_intPos As Integer) As String

  '変数の宣言
  Dim intLen As Integer
  Dim strBefore As String
  
  strBefore = in_strInput
  intLen = Len(strBefore)
  
  If in_intPos < 0 Or in_intPos > intLen Then
      Err.Raise Number:=19101, Description:= _
  "fnc_insrChar関数： 挿入位置の不正"
      Exit Function
  End If
  
   '戻り値の設定
  fnc_insrChar = Left$(strBefore, in_intPos) & _
      in_strChar & Right$(strBefore, intLen - in_intPos)

End Function

'★テキストを配列に格納
'★in:ファイルパス out:1次配列
Public Function fnc_readFile(ByVal filePath As String) As String()

  Dim strArray() As String
  Dim fso As Object
  
  'ファイル存在確認
  Set fso = CreateObject("Scripting.FileSystemObject")
  If fso.FileExists(filePath) = False Then
    fnc_readFile = strArray
    Exit Function
  End If
  Set fso = Nothing
  

  Dim intNo As Integer
  Dim intCount As Integer
  Dim strBuff As String
        
On Error GoTo Catch
        
  intNo = FreeFile()
  Open filePath For Input As #intNo       ' ファイルをオープン

  intCount = 1
  Do Until EOF(intNo)
    Line Input #intNo, strBuff
    ReDim Preserve strArray(intCount)
    strArray(intCount) = strBuff
    intCount = intCount + 1
  Loop
  
  'フルパスからファイル名を抽出
  Do
    n = InStr(n + 1, filePath, "\")
    If n > 0 Then
      Pos = n
    Else
      Exit Do
    End If
  Loop
  
  strArray(0) = Mid(filePath, Pos + 1)
        

Finally:
  fnc_readFile = strArray
  Close #intNo 'ファイルクローズ
  Exit Function
Catch:
  GoTo Finally

End Function

'■一次元配列を2つ繋げて二次元配列に変換するモジュール
'例)arrTotal = fnc_Array_MergeTo2D(arrTotal, arrTemp) '二つの一次元配列を二次元配列にする
Public Function fnc_Array_MergeTo2D(arr1 As Variant, arr2 As Variant) As Variant

  If UBound(arr1) > UBound(arr2) Then
    myRow = UBound(arr1)
  Else
    myRow = UBound(arr2)
  End If
     
  Dim buf() As String: ReDim buf(myRow, 1)
  
  If LBound(arr1) = 1 And LBound(arr2) = 1 Then
    i_st = 1
  End If

  For i = i_st To myRow
    If i <= UBound(arr1) Then
      buf(i, 0) = arr1(i)
    Else
      buf(i, 0) = Empty
    End If
    
    If i <= UBound(arr2) Then
      buf(i, 1) = arr2(i)
    Else
      buf(i, 1) = Empty
    End If
    
  Next
  fnc_Array_MergeTo2D = buf
End Function

'■二次元配列に一次元配列をマージする(横方向)
Public Function fnc_MergeArray_Column(arr1 As Variant, arr2 As Variant) As Variant
  
  '■結合(マージ)後の配列サイズ
  '■■列方向(横)に結合、行方向(縦)は二次元配列の大きい方に合わせる。
  Dim ROW_NEW As Long
  Dim COL_NEW As Long
  ROW_NEW = Application.WorksheetFunction.Max(UBound(arr1, 1), UBound(arr2))
  COL_NEW = UBound(arr1, 2) + 1
  
  '■結合(マージ)後の二次元配列
  Dim newArr As Variant
  ReDim newArr(0 To ROW_NEW, 0 To COL_NEW) '0からスタート
  
  '■結合処理
  For j = 0 To COL_NEW '0からスタート
    If j <= UBound(arr1, 2) Then
      For i = 0 To ROW_NEW '0からスタート
        If i <= UBound(arr1, 1) Then
          newArr(i, j) = arr1(i, j)
        Else
          newArr(i, j) = Empty
        End If
      Next
    Else
      For i = 0 To ROW_NEW '0からスタート
        If i <= UBound(arr2) Then
          newArr(i, j) = arr2(i)
        Else
          newArr(i, j) = Empty
        End If
      Next
    End If
  Next
  
  fnc_MergeArray_Column = newArr
    
End Function

'フォルダ1の中身がフォルダ2に全て入っおり、更新日付が完全一致するか確認(=コピペ成功してるか確認)
'入力：フォルダパス1、フォルダパス2
'出力：チェック結果(boolean)
Public Function fnc_CopyCheck(Folder1, Folder2) As Boolean

  Dim fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  Dim fName1() As String
  ReDim fName1(0)
  Dim fLastModified1() As Date
  ReDim fLastModified1(0)
  
  Dim fName2() As String
  ReDim fName2(0)
  Dim fLastModified2() As Date
  ReDim fLastModified2(0)

  '■フォルダ1のファイルと更新日付を配列に格納
  buf = Dir(Folder1 & "\*.csv")
  i = -1
  Do While Len(buf) > 0
    i = i + 1
    ReDim Preserve fName1(i)
    ReDim Preserve fLastModified1(i)
  
    Set f = fso.GetFile(Folder1 & "\" & buf) 'ファイルを取得
    fName1(i) = buf
    fLastModified1(i) = f.DateLastModified '更新日時を取得
    
    buf = Dir()
  Loop
  
  '■フォルダ2のファイルと更新日付を配列に格納
  buf = Dir(Folder2 & "\*.*")
  i = -1
  Do While Len(buf) > 0
    i = i + 1
    ReDim Preserve fName2(i)
    ReDim Preserve fLastModified2(i)
    
    Set f = fso.GetFile(Folder2 & "\" & buf)
    fName2(i) = buf
    fLastModified2(i) = f.DateLastModified '更新日時を取得
    
    buf = Dir()
  Loop

  '■フォルダ1のファイルがフォルダ2に全てあるか確認
  ct = -1
  For i = 0 To UBound(fName1)
    For j = 0 To UBound(fName2)
      If fName1(i) = fName2(j) And fLastModified1(i) = fLastModified2(j) Then
        ct = ct + 1
        Exit For
      End If
    Next
  Next

  If ct = UBound(fName1) Then
    fnc_CopyCheck = True
  Else
    fnc_CopyCheck = False
  End If

  '後片付け
  Set fso = Nothing

End Function

' 列番号→列名
Function fnc_ColumnIdx2Name(ByVal colNum As Long) As String
    fnc_ColumnIdx2Name = Split(Columns(colNum).Address, "$")(2)
End Function

'二次元配列の縦横を入れ替える
Function fnc_arrTranspose(arr As Variant) As Variant

  Dim tmp As Variant
  Dim r As Long, c As Long

  'arrの行列を入れ替えてtmpを宣言
  ReDim tmp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
   
  'arrの行列をtmpに入れていく
  For r = LBound(arr, 1) To UBound(arr, 1)
    For c = LBound(arr, 2) To UBound(arr, 2)
      tmp(c, r) = arr(r, c)
    Next c
  Next r

  fnc_arrTranspose = tmp
End Function

'二次元配列の一次元目を増やすor減らす
Public Function fnc_ArraySizeChange(arr As Variant, sLen As Variant)

  '仮配列tmpを作る
  Dim tmp As Variant
  ReDim tmp(LBound(arr, 1) To sLen, LBound(arr, 2) To UBound(arr, 2))
  
  If UBound(arr, 1) > sLen Then
    rMax = sLen
  Else
    rMax = UBound(arr, 1)
  End If
  
  'forでarr→tmpに入れる(増やした行は空白)
  Dim i As Long, j As Long
  For i = LBound(arr, 1) To rMax
    For j = LBound(arr, 2) To UBound(arr, 2)
      tmp(i, j) = arr(i, j)
    Next
  Next
  
  fnc_ArraySizeChange = tmp
  
End Function

'連番を付与して新規フォルダを作成する
Function fnc_MakeFolder(Path親フォルダ As String, 作成フォルダ名 As String _
  , Optional is第1フォルダにも付番する As Boolean = False) As String
  
  Dim path作成フォルダ As String
  path作成フォルダ = Path親フォルダ & "\" & 作成フォルダ名
      
   '作成するフォルダパス
  If Dir(path作成フォルダ, vbDirectory) <> "" Then
 
    'まだフォルダがない番号まで連番を進める
    Dim i As Long: i = 1
    Do While Dir(path作成フォルダ & "-" & i, vbDirectory) <> ""
        i = i + 1
    Loop
    
    '決まった番号を付番（オプションによっては1も付番）
    If i >= 1 Or is第1フォルダにも付番する Then
        path作成フォルダ = path作成フォルダ & "-" & i
    End If
  
  End If
  
  'フォルダを作成
  MkDir path作成フォルダ

  '作成したフォルダパスを返す
  fnc_MakeFolder = path作成フォルダ

End Function

'シートを削除する
Function fnc_DeleteSheet(sName As String)
  Dim ws As Worksheet
  Dim flag As Boolean
  
  '引数のシート名が存在していた場合削除
  For Each ws In Worksheets
    If ws.Name = sName Then flag = True
  Next
  
  If flag = True Then
    Application.DisplayAlerts = False
    Worksheets(sName).Delete
    Application.DisplayAlerts = True
  End If

End Function

Function fnc_NotSleep()

  Static NotSleepStartTime As Double

  '初回のみ
  If NotSleepStartTime = 0 Then
    NotSleepStartTime = Timer
  End If
  
  If Abs(Timer - NotSleepStartTime) >= 180 Then '180秒に1回。日付をまたぐことを想定して絶対値(Abs)
    'スリープ対策
    keybd_event 0, 0, 0, 0 '押す　[KeyCode=0]に設定
    keybd_event 0, 0, KEYEVENTF_KEYUP, 0 '放す
    NotSleepStartTime = Timer 'タイマーリセット
  End If
  
End Function

Function fnc_SaveLog()

  Dim objFSO As Object, txtSource As String, txtDestination
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  Static NotSleepStartTime As Double
  
  bk_name = ActiveWorkbook.Name
  bookName = Left(bk_name, InStrRev(bk_name, ".") - 1)
  SaveDir = ActiveWorkbook.Path & "\【Log】" & bookName
  
  'フォルダがなければ作成する
  If Dir(SaveDir, vbDirectory) = "" Then
    MkDir SaveDir
  End If
  
  If NotSleepStartTime = 0 Then
    '初回のみセーブせずにバックアップ
    NotSleepStartTime = Timer
    objFSO.CopyFile ActiveWorkbook.FullName, SaveDir & "\" & Format(Now, "mmhhnnss") & "_" & ActiveWorkbook.Name
  End If
  
  If Abs(Timer - NotSleepStartTime) >= 180 Then '180秒に1回。日付をまたぐことを想定して絶対値(Abs)
    'セーブしてからバックアップ
    ActiveWorkbook.Save
    objFSO.CopyFile ActiveWorkbook.FullName, SaveDir & "\" & Format(Now, "mmddhhnnss") & "_" & ActiveWorkbook.Name
    
    'スリープ対策
    keybd_event 0, 0, 0, 0 '押す　[KeyCode=0]に設定
    keybd_event 0, 0, KEYEVENTF_KEYUP, 0 '放す
    NotSleepStartTime = Timer 'タイマーリセット
  End If
  
End Function

Public Function fnc_SelectFileInExplorer(ByVal TargetFilePath As String)
'指定したファイルをエクスプローラーで開いて選択する
  With CreateObject("Scripting.FileSystemObject")
    If .FileExists(TargetFilePath) = True Then
      Shell "EXPLORER.EXE /select,""" & TargetFilePath & """", vbNormalFocus
    Else
      MsgBox TargetFilePath & vbCrLf & "のファイルは存在しません。"
    End If
  End With
End Function

Function fnc_OpenFolder(TargetFolderPath As String) As Boolean
  If Dir(TargetFolderPath, vbDirectory) <> "" Then
    Shell "C:\windows\explorer.exe " & TargetFolderPath, vbNormalFocus
    フォルダをエクスプローラーで開く = True
  Else
    MsgBox TargetFolderPath & vbCrLf & "のフォルダ存在しません"
  End If
End Function

'**********************************************************************
' sDir : 対象フォルダ
' sMsg : エラー発生時のメッセージ保存
' isOnlyFile : ファイルのみ削除する場合にTrue
'**********************************************************************
Function fnc_DelFolder(ByVal sDir As String, _
                Optional ByVal isOnlyFile As Boolean = False) As Boolean
    Dim objFSO As New FileSystemObject
    Dim objFolder As Folder
    Dim sMsg As String
    
    sMsg = ""
    If Not objFSO.FolderExists(sDir) Then
        MsgBox "指定のフォルダは存在しません。"
        Exit Function
    End If
    
    Set objFolder = objFSO.GetFolder(sDir)
    Call DelDirectorys(objFolder, isOnlyFile, sMsg)
    
    If sMsg <> "" Then
        MsgBox sMsg
    End If
End Function

Sub DelDirectorys(ByVal objFolder As Folder, _
                    ByVal isOnlyFile As Boolean, _
                    ByRef sMsg As String)
    Dim objFolderSub As Folder
    Dim objFile As File
    On Error Resume Next
    For Each objFolderSub In objFolder.SubFolders
        Call DelDirectorys(objFolderSub, isOnlyFile, sMsg)
    Next
    For Each objFile In objFolder.Files
        objFile.Delete
        If Err.Number <> 0 Then
            sMsg = sMsg & "ファイル「" & objFile.Path & "」が削除できませんでした" & vbLf
            Err.Clear
        End If
    Next
    If Not isOnlyFile Then
        objFolder.Delete
        If Err.Number <> 0 Then
            sMsg = sMsg & "フォルダ「" & objFolder.Path & "」が削除できませんでした" & vbLf
            Err.Clear
        End If
    End If
    Set objFolderSub = Nothing
    Set objFile = Nothing
    On Error GoTo 0
End Sub

Function fnc_Un7zip(a_sZipPath As String, Optional a_sMakeDirectory As String = "", Optional a_sPassword As String = "")
    Dim wsh     As Object   '// WshShellクラス
    Dim s7zPath As String   '// 7z.exeのフルパス
    Dim sCmd    As String   '// コマンド文字列
    
    s7zPath = """C:\Program Files\7-Zip\7z.exe"""
    sCmd = s7zPath & " x "
    
    '// 引数で解凍先ディレクトリが設定されている場合
    If a_sMakeDirectory <> "" Then
        sCmd = sCmd & "-o" & chr(34) & a_sMakeDirectory & chr(34) & " "
        
    '// 解凍先ディレクトリが設定されていない場合は圧縮ファイルがあるフォルダを解凍先とする
    Else
        sCmd = sCmd & "-o" & chr(34) & Left(a_sZipPath, InStrRev(a_sZipPath, "\")) & chr(34) & " "
    End If
    
    '// 引数でパスワードが設定されている場合（-p + パスワード　を付与）
    If a_sPassword <> "" Then
        sCmd = sCmd & "-p" & a_sPassword & " "
    End If
        
    '// 「7z.exe x [-o解凍先フォルダ] [-pパスワード] -y 圧縮ファイルパス」のコマンド文字列を作成
    '// -yは解凍時の問い合わせを全て「Yes」として扱う
    sCmd = sCmd & "-y " & chr(34) & a_sZipPath & chr(34)
    
    '// WshShellオブジェクトを作成
    Set wsh = CreateObject("WScript.Shell")
    
    '// 7-Zipの解凍コマンドを実行
    Call wsh.Run(sCmd)
End Function

Public Function fnc_ExistFileCheck(a_sFilePath) As Boolean
    If (Dir(a_sFilePath) <> "") Then
        fnc_ExistFileCheck = True
    Else
        fnc_ExistFileCheck = False
    End If
End Function

Function fnc_ReadOnlyCheck(a_sFilePath) As Boolean
    Dim ret As VbFileAttribute
    
    '// ファイルの属性を取得
    ret = GetAttr(a_sFilePath)
    
    '// 読み取り専用が設定されている場合
    If (ret And vbReadOnly) = vbReadOnly Then
        fnc_ReadOnlyCheck = True
    Else
        fnc_ReadOnlyCheck = False
    End If
End Function

Function fnc_OpenText(fPath) As String

  Dim wsh
  Set wsh = CreateObject("Wscript.Shell")
  wsh.Run chr(34) & fPath & chr(34), 1
  Set wsh = Nothing
  
  'bHide 0 ウィンドウは非表示で、フォーカスは非表示ウィンドウに渡されます。 vbHide 定数は Macintosh プラットフォームでは適用されません。
  'vbNormalFocus 1 ウィンドウがフォーカスを持ち、元のサイズと位置に復元されます。
  'vbMinimizedFocus  2 ウィンドウがフォーカスを持ってアイコンとして表示されます。
  'vbMaximizedFocus  3 ウィンドウがフォーカスを持って最大化されます。
  'vbNormalNoFocus 4 ウィンドウは、最新のサイズと位置に復元されます。 現在アクティブなウィンドウはアクティブのままです。
  'vbMinimizedNoFocus  6 ウィンドウはアイコンとして表示されます。 現在アクティブなウィンドウはアクティブのままです。

End Function

Function fnc_DelBracket _
                  (ByVal objStr As String, _
                   ByVal startBracket As String, _
                   ByVal endBracket As String) As String
  Dim enableToDelete As Boolean
  Dim tmp As String
  Dim chr As String
  Dim i As Integer
  For i = 1 To Len(objStr)
    chr = Mid(objStr, i, 1)
    If chr = startBracket Then
      enableToDelete = True
    End If
    If chr = endBracket Then
      enableToDelete = False
      chr = ""
    End If
    If enableToDelete = False Then
      tmp = tmp & chr
    End If
    If enableToDelete = True Then
    End If
  Next
  fnc_DelBracket = tmp
End Function

Function fnc_ClipBoardSave(tmp As String, Optional msg As Boolean = False)

  'クリップボードにコピー
  With CreateObject("Forms.TextBox.1")
    .MultiLine = True
    .Text = tmp
    .SelStart = 0
    .SelLength = .TextLength
    .Copy
  End With
  
  'コピーできてるか確認
  tempObject = Application.ClipboardFormats
  If tempObject(1) = -1 Then
    'MsgBox "クリップボードには何も入っていません。"
    MsgBox "コピー失敗"
  Else
  
    With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
      .GetFromClipboard
      GetCB = .GetText
  
      If tmp <> GetCB Then
        MsgBox "コピー失敗"
        Exit Function
      ElseIf msg = True Then
        MsgBox tmp & vbCrLf & vbCrLf & "をクリップボードにコピーしました。"
      End If
    End With
    
  End If
  
End Function

Function fnc_ReplaceStr(ByVal str As String) As String
    str = Replace(str, "\", "￥")
    str = Replace(str, "/", "／")
    str = Replace(str, ":", "：")
    str = Replace(str, "*", "＊")
    str = Replace(str, "?", "？")
    str = Replace(str, """", chr(&H8168)) ' VBAでは全角のダブルクォーテーションが打てない
    str = Replace(str, "<", "＜")
    str = Replace(str, ">", "＞")
    str = Replace(str, "|", "｜")
    fnc_ReplaceStr = str
End Function

Function fnc_rc(ByRef RowEnd As Variant, ByRef ColumnEnd As Variant, Optional WorksheetName As String = "")
  
  If WorksheetName = "" Then
    Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
    Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
    RowEnd = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    ColumnEnd = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  Else
    
    If fnc_ExistsSheet(WorksheetName) = False Then
      MsgBox "「" & WorksheetName & "」シートが存在しません。" & vbCrLf & _
      "マクロを終了します。"
      End
    End If
    
    Dim ws As Worksheet
    Set ws = Worksheets(WorksheetName)
    
    Dummy = ws.UsedRange.Row '終端セル誤認バグ修正
    Dummy = ws.UsedRange.Column '終端セル誤認バグ修正
    RowEnd = ws.Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    ColumnEnd = ws.Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  End If
End Function

'指定した名前のシートが存在するか判定する
Public Function fnc_ExistsSheet(ByVal WorksheetName As String)
    Dim ws As Variant
    For Each ws In Sheets
        If LCase(ws.Name) = LCase(WorksheetName) Then
            fnc_ExistsSheet = True '存在する
            Exit Function
        End If
    Next

    ExistsSheet = False '存在しない
End Function

Function fnc_StatusBar(top As Variant, bot As Variant)

  Application.StatusBar = "進行状況：" & top & "/" & bot

  '画面が固まる場合は一定カウント事にDoEventsを入れる｡
  If top Mod 100 = 0 Then
    DoEvents
  End If

End Function

Function fnc_st()
  Application.ScreenUpdating = False '画面更新非表示
  Application.Calculation = xlCalculationManual '数式計算停止
  Application.EnableEvents = False '自動実行マクロ停止
End Function

Function fnc_end()
  Application.ScreenUpdating = True '画面更新表示
  Application.Calculation = xlCalculationAutomatic '数式計算再開
  Application.EnableEvents = True '自動実行マクロ再開
  Application.StatusBar = False 'ステータスバー非表示
End Function

Attribute VB_Name = "M01_A1セルに移動"
Sub A1セルに移動()

  Application.ScreenUpdating = False '画面更新非表示

  For i = 1 To Worksheets.Count
    Sheets(i).Activate
    Application.GoTo Reference:=Cells(1, 1), Scroll:=True
  Next

  Sheets(1).Activate

End Sub
Attribute VB_Name = "M02_シート表示倍率変更"
Sub シート表示倍率変更()

  Application.ScreenUpdating = False '画面更新非表示

  UserForm1.Show

End Sub

Attribute VB_Name = "M03_シート再表示"
Sub シート再表示()

  Dim sh As Worksheet
  
  For Each sh In Worksheets
    sh.Visible = True
  Next

End Sub
Attribute VB_Name = "M04_行色塗り"
Sub 行色塗り()

  Application.ScreenUpdating = False '画面更新非表示
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  
  If Cells(2, 1).Interior.Color = RGB(255, 204, 152) Then
    Cells.Interior.ColorIndex = xlNone 'シート全体塗りつぶしなし
    Cells.Borders.LineStyle = xlLineStyleNone ' シート全体の罫線を消す
  Else
    Cells.Interior.ColorIndex = xlNone 'シート全体塗りつぶしなし
    For i = 2 To r Step 2
      Rows(i).Interior.Color = RGB(255, 204, 152) 'セル色塗り
      Rows(i).Borders(xlEdgeTop).LineStyle = xlContinuous 'セル枠線上のみ
      Rows(i).Borders(xlEdgeBottom).LineStyle = xlContinuous 'セル枠線下のみ
    Next
  End If


End Sub
Attribute VB_Name = "M05_列色塗り"
Sub 列色塗り()

  Application.ScreenUpdating = False '画面更新非表示
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  
  If Cells(1, 2).Interior.Color = RGB(255, 204, 152) Then
    Cells.Interior.ColorIndex = xlNone 'シート全体塗りつぶしなし
    Cells.Borders.LineStyle = xlLineStyleNone ' シート全体の罫線を消す
  Else
    Cells.Interior.ColorIndex = xlNone 'シート全体塗りつぶしなし
    For i = 2 To c Step 2
      Columns(i).Interior.Color = RGB(255, 204, 152)  'セル色塗り
      Columns(i).Borders(xlEdgeLeft).LineStyle = xlContinuous 'セル枠線左のみ
      Columns(i).Borders(xlEdgeRight).LineStyle = xlContinuous 'セル枠線右のみ
    Next
  End If


End Sub
Attribute VB_Name = "M06_大文字小文字変換"
Sub 大文字小文字変換()

  Application.ScreenUpdating = False '画面更新非表示
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  
  Dim tmp()
  ReDim tmp(1 To r, 1 To c)
  Dim a As String
  Dim B As String
  
  flag = 0
  For i = 1 To r
    For j = 1 To c
      a = Cells(i, j)
      B = UCase(Cells(i, j))
    
      If a <> B Then 'シートのどこかに一文字でも小文字が含まれている場合flag = 1
        flag = 1
        Exit For
      End If
    Next
    
    If flag = 1 Then Exit For
  Next
  
  
  If flag = 0 Then
    For i = 1 To r
      For j = 1 To c
        tmp(i, j) = LCase(Cells(i, j)) '小文字に変換
      Next
    Next
  Else
    For i = 1 To r
      For j = 1 To c
        tmp(i, j) = UCase(Cells(i, j)) '大文字に変換
      Next
    Next
  End If
  
  Range(Cells(1, 1), Cells(r, c)) = tmp

End Sub
Attribute VB_Name = "M07_CSV出力"
Sub CSV出力()

  Dim ws As Worksheet
  Set ws = ActiveWorkbook.ActiveSheet
  
  Filename = ActiveSheet.Name
    
  folderPath = "C:\Users\10035690229\Desktop\比較"
  csvFile = folderPath & "\" & Filename & ".csv"
  
  '比較フォルダがなければ作る
  If Dir(folderPath, vbDirectory) = "" Then
    MkDir folderPath
  End If
 

  '名前のダブり確認*開始***************************************************
  fn = folderPath & "\*" & Filename & "*"
  fnd = Dir(fn, vbNormal)
  i = 0
  'ファイルがない場合
  If (fnd = "") Then
    GoTo CONTINUE1
    'ファイルがあった場合
  Else
    Do While fnd <> ""
      fnd = Dir '次のファイル
      i = i + 1
    Loop
  End If
  Filename = Filename & "(" & i & ")"
 
CONTINUE1:
 
  '名前のダブり確認*終了***************************************************
 
  fname = folderPath & "\" & Filename & ".csv"
  
  'ファイルナンバーを割り当て
  FileNumber = FreeFile
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列

  'ファイルへの書き出し
  Open fname For Output As #FileNumber

  '1列全て書き出したら、次の行へ
  For i = 1 To r
    For j = 1 To c
      If j <> c Then
        Print #FileNumber, ws.Cells(i, j).Value & ",";  '最終列でなければセルの値とカンマ
      Else
        Print #FileNumber, ws.Cells(i, j).Value & vbCr;  '最終列ならば、セルの値と改行コード
      End If
    Next
  Next

  'ファイルを閉じる
  Close #FileNumber
  
  CreateObject("WScript.Shell").Run folderPath
End Sub
Attribute VB_Name = "M08_列幅自動調整"
Sub 列幅自動調整()

  Application.ScreenUpdating = False
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列

  For i = 1 To c
    For j = 1 To r
      If Cells(i, j) <> "" Then
        Columns(j).ColumnWidth = 200
        Exit For
      End If
    Next
  Next

  Cells.EntireRow.AutoFit 'シート全体の行の高さを自動調整
  Cells.EntireColumn.AutoFit 'シート全体の列幅自動調整


End Sub
Attribute VB_Name = "M09_コメント幅調整"
Sub コメント幅調整()

  Application.ScreenUpdating = False

  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番下の行
  
  For i = 1 To r
    For j = 1 To c
      If TypeName(Cells(i, j).Comment) = "Comment" Then
        Cells(i, j).Comment.Shape.TextFrame.AutoSize = True 'コメント幅整理
      End If
    Next
  Next

End Sub
Attribute VB_Name = "M10_文字色塗り"
Sub 文字色塗り()
 
  Dim myStr As String
  Dim myArray() As String
  myStr = InputBox("赤色で塗りつぶしたい文字を入力して下さい。" & vbCrLf & _
  "複数文字を入れる場合は「,」で区切って下さい。")
  If myStr = "" Then
    End
  End If
   
  Application.ScreenUpdating = False
 
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  
  myArray() = Split(myStr, ",")
  ct = 0
   
  For x = 1 To r
    For y = 1 To c
      CelLen = Len(Cells(x, y)) 'セル内の文字数
      
      For i = 0 To UBound(myArray)
        MyData = myArray(i)  '検索対象文字
        MyDataLen = Len(MyData) '検索対象文字数

        Poji = InStr(Cells(x, y).Value, MyData) '検索してヒットしたら色変更
        If Poji > 0 Then
          Cells(x, y).Characters(Poji, MyDataLen).Font.Color = RGB(255, 0, 0)
          ct = ct + 1
        End If

        For j = 0 To CelLen
          Poji = InStr((Poji + MyDataLen), Cells(x, y).Value, MyData)  '検索してヒットしたら色変更
             
          If Poji = 0 Then
            Exit For
          End If
             
          Cells(x, y).Characters(Poji, MyDataLen).Font.Color = RGB(255, 0, 0)
          ct = ct + 1
        Next

      Next
   
    Next
  Next
   
  Application.ScreenUpdating = True
  
  MsgBox ct & "箇所文字に色を塗りました。"
 
End Sub


Attribute VB_Name = "M11_赤文字チェック"
Private counter As Long
Private before_x As Long
Private before_y As Long
Private before_ws As String

Sub 赤文字チェック()

  Application.ScreenUpdating = False '画面更新非表示
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  
  Dim n1 As Long
  Dim n2 As Long
  
  ctflag = 1
  For x = 1 To r
    For y = 1 To c
    
      '前回の続きのセルから検索
      If counter <> 0 And ctflag = 1 Then
        If before_ws = ActiveSheet.Name Then
'          If y = c Then
            x = before_x + 1
            y = 1
'          Else
'            x = before_x
'            y = before_y + 1
'          End If
        Else
          counter = 0
        End If
        
        ctflag = 0
      End If
      
      If Cells(x, y) <> "" Then
    
        FullColor = Cells(x, y).Font.ColorIndex
        
        'セル内の文字が全て赤の場合
        If FullColor = 3 Then
          Application.GoTo Reference:=Cells(x, y), Scroll:=True
          counter = counter + 1
          before_x = x
          before_y = y
          before_ws = ActiveSheet.Name
          Exit Sub
        End If
        
        'セル内の文字が複数色ある場合はn分割してから一文字ずつチェック
        If IsNull(FullColor) Then
        
          n1 = Len(Cells(x, y)) / 2
          n2 = Len(Cells(x, y)) - n1
        
          n1Color = Cells(x, y).Characters(Start:=1, Length:=n1).Font.ColorIndex
          n2Color = Cells(x, y).Characters(Start:=n1 + 1, Length:=n2).Font.ColorIndex
          n1flag = 0
        
          For j = 1 To n1
            SingleColor = Cells(x, y).Characters(Start:=j, Length:=1).Font.ColorIndex
            
            If SingleColor = 3 Then
              n1flag = 1
              Exit For
            End If
          Next
          
          If n1flag = 0 Then
            For j = n2 To Len(Cells(x, y))
              SingleColor = Cells(x, y).Characters(Start:=j, Length:=1).Font.ColorIndex
              
              If SingleColor = 3 Then
                Exit For
              End If
            Next
          End If
        
          If SingleColor = 3 Then
            SingleColor = 0
            Application.GoTo Reference:=Cells(x, y), Scroll:=True
            counter = counter + 1
            before_x = x
            before_y = y
            before_ws = ActiveSheet.Name
            Exit Sub
          End If
          
        End If
        
      End If
      
    Next
  Next

  If counter = 0 Then
    MsgBox "赤文字はありませんでした。"
  Else
    MsgBox "これ以上赤文字はありません。"
  End If
  
  counter = 0

End Sub
Attribute VB_Name = "M12_OK_NG強調表示"
Sub OK_NG強調表示()

  Application.ScreenUpdating = False

  Dim myCond As FormatCondition

  With Selection
    .FormatConditions.Delete 'セルの書式設定削除
    Set myCond = .FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""OK""")
    myCond.Font.Color = -16752384
    myCond.Interior.Color = 13561798
    
    Set myCond = .FormatConditions.Add(Type:=xlCellValue, Operator:=xlEqual, Formula1:="=""NG""")
    myCond.Font.Color = -16383844
    myCond.Interior.Color = 13551615
  End With

  Selection.FormatConditions(1).StopIfTrue = False

End Sub

Attribute VB_Name = "M13_語尾追加"
Sub 語尾修正()

  Application.ScreenUpdating = False
  
  If Selection.Areas.Count <> 1 Then
    MsgBox "1つのセル範囲のみ選択して下さい"
    End
  End If
  
  strIn = InputBox("語尾につける文章を入力して下さい。" & vbCrLf & "語尾を消す場合は「-文字数」を入力して下さい。")
  
  If strIn = "" Then
    End
  End If
  
  On Error Resume Next
  
  flag = 0
  If IsNumeric(strIn) Then
    If strIn < 0 Then
      flag = 1
    
      For i = Selection(1).Row To Selection(Selection.Count).Row
        For j = Selection(1).Column To Selection(Selection.Count).Column
          str_ct = Len(Cells(i, j)) + strIn
          Cells(i, j) = Left(Cells(i, j), str_ct)
        Next
      Next
      
    End If
  End If
  
  If Err.Number <> 0 And flag = 1 Then
    Application.ScreenUpdating = True
    MsgBox "文字数が不足してるセルは無視しました。"
  End If
  
  On Error GoTo 0
  
  If flag = 1 Then End '数字だった場合はここで終了
  
  ct = 1
  For i = Selection(1).Row To Selection(Selection.Count).Row
    For j = Selection(1).Column To Selection(Selection.Count).Column
      Cells(i, j) = Cells(i, j) & strIn
    Next
  Next

End Sub
Attribute VB_Name = "M14_語尾赤色"
Sub 語尾赤色()

  Application.ScreenUpdating = False
  
  If Selection.Areas.Count <> 1 Then
    MsgBox "1つのセル範囲のみ選択して下さい"
    End
  End If
  
  myNum = Application.InputBox(prompt:="赤色にする語尾の文字数を入力して下さい。", Type:=1)
  
  If VarType(myNum) = vbBoolean Then 'キャンセル処置
    End
  End If
  
  flag = 0
  For i = Selection(1).Row To Selection(Selection.Count).Row
    For j = Selection(1).Column To Selection(Selection.Count).Column
      If Len(Cells(i, j)) >= myNum Then
        Poji = Len(Cells(i, j)) - myNum + 1
        Cells(i, j).Characters(Poji, myNum).Font.Color = RGB(255, 0, 0)
      Else
        flag = 1
      End If
    Next
  Next
      
  If flag = 1 Then
    Application.ScreenUpdating = True
    MsgBox "処置完了。" & vbCrLf & "文字数が不足してるセルは無視しました。"
  End If
  
End Sub
Attribute VB_Name = "M15_選択シート比較"
Sub シート比較()

  Application.ScreenUpdating = False '画面更新非表示
  
  If ActiveWindow.SelectedSheets.Count <> 2 Then
    MsgBox "比較する二つのシートをアクティブにして下さい"
    End
  End If
  
  st1 = ActiveWindow.SelectedSheets(1).Name
  st2 = ActiveWindow.SelectedSheets(2).Name
    
  Dim arr1 As Variant
  Dim arr2 As Variant
  
  With Worksheets(st1)
    Dummy = .UsedRange.Row '終端セル誤認バグ修正
    Dummy = .UsedRange.Column '終端セル誤認バグ修正
    r1 = .Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    c1 = .Range("A1").SpecialCells(xlLastCell).Column '一番右の列
    'arr1 = .Range(.Cells(1, 1), .Cells(r1, c1))
  End With
  
  With Worksheets(st2)
    Dummy = .UsedRange.Row '終端セル誤認バグ修正
    Dummy = .UsedRange.Column '終端セル誤認バグ修正
    r2 = .Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    c2 = .Range("A1").SpecialCells(xlLastCell).Column '一番右の列
    'arr2 = .Range(.Cells(1, 1), .Cells(r2, c2))
  End With
  
  If r1 > r2 Then
    r_max = r1
  Else
    r_max = r2
  End If
  
  If c1 > c2 Then
    c_max = c1
  Else
    c_max = c2
  End If
  
  If r_max = 1 Then
    r_max = 2
  End If
  
  If c_max = 1 Then
    c_max = 2
  End If
  
  arr1 = Worksheets(st1).Range(Worksheets(st1).Cells(1, 1), Worksheets(st1).Cells(r_max, c_max))
  arr2 = Worksheets(st2).Range(Worksheets(st2).Cells(1, 1), Worksheets(st2).Cells(r_max, c_max))
  
  temp = "不一致セル："
  flag = 0
  For i = 1 To r_max
    For j = 1 To c_max
    
      
      If arr1(i, j) <> arr2(i, j) Then
        If flag = 1 Then
          temp = temp & ","
        End If
      
        temp = temp & Cells(i, j).Address(False, False)
        flag = 1
      End If
    Next
  Next
  
  If flag = 0 Then
    temp = "全セル一致"
  End If
  
  MsgBox temp
  
End Sub

Attribute VB_Name = "M16_図形文字削除"
Sub 図形文字削除()

  Dim shp As Shape
  
  i = 0
  flag = 0
  For Each shp In ActiveWorkbook.ActiveSheet.Shapes
    flag = 1
    If shp.TextFrame2.HasText Then
      shp.TextFrame2.TextRange.Text = ""
      i = i + 1
    End If
  Next
  
  If flag = 0 Then
    MsgBox "図形がありませんでした。"
  ElseIf i = 0 Then
    MsgBox "図形の中に文字がありませんでした。"
  Else
    MsgBox i & "個の図形の文字を消しました"
  End If
  
End Sub

Attribute VB_Name = "M17_文字修正"
Sub 文字修正()

  Application.ScreenUpdating = False '画面更新非表示
  UserForm2.Show

End Sub

Attribute VB_Name = "M18_可視セルコピー"
Public CopyCell() As Variant

Sub 可視セルコピー()
  Erase CopyCell '配列初期化

  Application.ScreenUpdating = False '画面更新非表示
  
  a = Selection.Row '先頭行
  B = Selection.Rows.Count '選択行の数
  c = Selection.Column '先頭列
  d = Selection.Columns.Count '選択列の数
  rEnd = a + B - 1
  cEnd = c + d - 1
  
  Dim arrSheet()
  arrSheet = Range(Cells(1, 1), Cells(rEnd, cEnd))
  
  ReDim CopyCell(1 To rEnd, 1 To cEnd)
  
  ct = 0
  For i = a To rEnd
  
    If Rows(i).Hidden = False Then
      ct = ct + 1
      For j = 1 To d
        CopyCell(ct, j) = arrSheet(i, j + c - 1)
      Next
    End If
    
  Next
  
  ReDim Preserve CopyCell(1 To rEnd, 1 To d) '二次元目を宣言し直し
  CopyCell = fnc_ArraySizeChange(CopyCell, ct) '一次元目を宣言し直し

End Sub
Attribute VB_Name = "M19_可視セル貼り付け"
Sub 可視セル貼り付け()

  If (Not CopyCell) = -1 Then
    MsgBox "配列が空です。"
    End
  End If

  Application.ScreenUpdating = False '画面更新非表示

  a = Selection.Row '先頭行
  c = Selection.Column '先頭列

  ct_r = 1
  i = 1
  Do While (ct_r <= UBound(CopyCell, 1))
    If Rows(i + a - 1).Hidden = False Then
      '2次元配列のi行目を一括で貼り付ける
      Range(Cells(i + a - 1, c), Cells(i + a - 1, c - 1 + UBound(CopyCell, 2))).Value = WorksheetFunction.Index(CopyCell, ct_r, 0)
      ct_r = ct_r + 1
    End If
  
    i = i + 1
  Loop
    
End Sub

Attribute VB_Name = "M20_グループで色塗り"
Sub グループで色塗り()

  Application.ScreenUpdating = False '画面更新非表示
  
  a = Selection.Row '先頭行
  B = Selection.Rows.Count '選択行の数
  c = Selection.Column '先頭列
  d = Selection.Columns.Count '選択列の数
  
  '列が選択されてる場合
  If B >= 1048576 Then
    Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
    B = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  End If
  
  rEnd = a + B - 1

  Dim arrData()
  ReDim arrData(0)
  Dim arrRowNo()
  ReDim arrRowNo(0)
    
  ct = -1
  For i = a To rEnd
  
    If Rows(i).Hidden = False Then
      ct = ct + 1
      ReDim Preserve arrData(ct)
      ReDim Preserve arrRowNo(ct)
    
      arrData(ct) = Cells(i, c)
      arrRowNo(ct) = i
  
    End If
  
  Next
  
    
  flag = 0
  color_ct = 0
  color_jdg = 0
  
  For i = 1 To ct
    If arrData(i) = arrData(i - 1) And arrData(i) <> "" And arrData(i) <> " " Then
    
      If color_jdg Mod 2 = 0 Then
        Cells(arrRowNo(i - 1), c).Interior.Color = RGB(255, 255, 0) 'セル背景色
        Cells(arrRowNo(i), c).Interior.Color = RGB(255, 255, 0) 'セル背景色
      Else
        Cells(arrRowNo(i - 1), c).Interior.Color = RGB(0, 255, 0) 'セル背景色
        Cells(arrRowNo(i), c).Interior.Color = RGB(0, 255, 0) 'セル背景色
      End If
      
      color_ct = color_ct + 1
    Else
    
      If color_ct <> 0 Then
        color_jdg = color_jdg + 1
      End If
    
      color_ct = 0
      
    End If
  Next

End Sub

Attribute VB_Name = "M21_列幅コピー"
Public myColumnWidth() As Variant

Sub 列幅コピー()

  ReDim myColumnWidth(0) '配列初期化

  Application.ScreenUpdating = False '画面更新非表示
  
  'a = Selection.Row '先頭行
  'b = Selection.Rows.Count '選択行の数
  c = Selection.Column '先頭列
  d = Selection.Columns.Count '選択列の数
  'rEnd = a + b - 1
  cEnd = c + d - 1
  
  ct = -1
  For i = c To cEnd
    ct = ct + 1
    ReDim Preserve myColumnWidth(ct)
    myColumnWidth(ct) = Columns(i).ColumnWidth
  Next

End Sub

Attribute VB_Name = "M22_列幅貼り付け"
Sub 列幅貼り付け()

  If (Not myColumnWidth) = -1 Then
    MsgBox "配列が空です。"
    End
  End If

  Application.ScreenUpdating = False '画面更新非表示
  
  c = Selection.Column '選択列
  
  For i = 0 To UBound(myColumnWidth)
    Columns(c + i).ColumnWidth = myColumnWidth(i)
  Next

End Sub

Attribute VB_Name = "M23_文字数カウント"
Sub 文字数カウント()
  
  If Selection.Areas.Count <> 1 Then
    MsgBox "1つのセル範囲のみ選択して下さい"
    End
  End If

  MsgBox Len(ActiveCell)


End Sub
Attribute VB_Name = "M24_文字で背景色1"
Sub 文字で背景色1()

  Dim myStr As String
  Dim myArray() As String
  
  myStr = InputBox("黄色でセルを塗りつぶしたい文字を入力して下さい。")
  If myStr = "" Then
    End
  End If
  
  Application.ScreenUpdating = False
  
  a = Selection.Row '先頭行
  B = Selection.Rows.Count '選択行の数
  c = Selection.Column '先頭列
  d = Selection.Columns.Count '選択列の数
  
  For i = a To a + B - 1
    For j = c To c + d - 1
      
      If Cells(i, j) = myStr Then
        Cells(i, j).Interior.Color = RGB(255, 255, 0) 'セル背景色
      End If
    Next
  Next
  
End Sub
Attribute VB_Name = "M25_文字で背景色2"
Sub 文字で背景色2()

  Dim myStr As String
  Dim myArray() As String
  
  myStr = InputBox("黄色でセルを塗りつぶしたい文字を入力して下さい。")
  If myStr = "" Then
    End
  End If
  
  Application.ScreenUpdating = False
  
  a = Selection.Row '先頭行
  B = Selection.Rows.Count '選択行の数
  c = Selection.Column '先頭列
  d = Selection.Columns.Count '選択列の数
  
  For i = a To a + B - 1
    For j = c To c + d - 1
      
      If Cells(i, j) = myStr Then
        Cells(i, j).Interior.Color = RGB(0, 255, 0) 'セル背景色
      End If
    Next
  Next
  
End Sub

Attribute VB_Name = "M26_文字で背景色3"
Sub 文字で背景色3()

  Dim myStr As String
  Dim myArray() As String
  
  myStr = InputBox("黄色でセルを塗りつぶしたい文字を入力して下さい。")
  If myStr = "" Then
    End
  End If
  
  Application.ScreenUpdating = False
  
  a = Selection.Row '先頭行
  B = Selection.Rows.Count '選択行の数
  c = Selection.Column '先頭列
  d = Selection.Columns.Count '選択列の数
  
  For i = a To a + B - 1
    For j = c To c + d - 1
      
      If Cells(i, j) = myStr Then
        Cells(i, j).Interior.Color = RGB(0, 255, 255) 'セル背景色
      End If
    Next
  Next
  
End Sub


Attribute VB_Name = "M27_ラベル_単体"
Sub ラベル_単体()

  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 0, 0, 500, 30).Select
  With Selection.ShapeRange.Fill
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 255, 0)
    .Transparency = 0
    .Solid
  End With
  With Selection.ShapeRange.Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
  End With
  With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
    .Solid
  End With
  Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
  Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "ラベル："
  Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 16
  Selection.ShapeRange.top = Range("F3").top
  Selection.ShapeRange.Left = Range("F3").Left

End Sub
Attribute VB_Name = "M28_ラベル_カバレッジ"
Sub ラベル_カバレッジ()

  ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, 53.25, 18.75, 472.5 _
      , 22.2).Select
  With Selection.ShapeRange.Fill
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 255, 0)
    .Transparency = 0
    .Solid
  End With
  With Selection.ShapeRange.Line
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
  End With
  With Selection.ShapeRange.TextFrame2.TextRange.Font.Fill
    .Visible = msoTrue
    .ForeColor.RGB = RGB(255, 0, 0)
    .Transparency = 0
    .Solid
  End With
  Selection.ShapeRange.TextFrame2.VerticalAnchor = msoAnchorMiddle
  Selection.ShapeRange.TextFrame2.TextRange.Characters.Text = "ラベル："
  Selection.ShapeRange.TextFrame2.TextRange.Font.Size = 11
  Selection.ShapeRange.top = 8
  Selection.ShapeRange.Left = Range("E1").Left

End Sub
Attribute VB_Name = "M29_テキストボックス検索"
Sub テキストボックス検索()

  Application.ScreenUpdating = False
  Cells(1, 1).Select
  Application.ScreenUpdating = True
  
  strIn = InputBox("検索する単語を入力して下さい。")
  
  If strIn = "" Then
    Exit Sub
  End If
  
  Application.ScreenUpdating = False
  
  ct = 0
  For Each shp In ActiveSheet.Shapes 'シート内の全ての図形をループ
    If shp.Type = 1 Or shp.Type = 2 Or shp.Type = 17 Then
    
      If shp.TextFrame2.HasText Then 'テキストが存在する場合
        If InStr(shp.TextFrame2.TextRange.Text, strIn) > 0 Then '文字が含まれている場合
          shp.Select False '選択する
          ct = ct + 1
        End If
      End If
      
    End If
  Next
  
  Application.ScreenUpdating = True
    
  If ct = 0 Then
    MsgBox strIn & vbCrLf & "はありませんでした。"
  Else
    MsgBox strIn & vbCrLf & "は" & ct & "個ありました。"
  End If
  
End Sub
Attribute VB_Name = "M30_CBフィルタ"
Sub CBフィルタ()

  Dim cbData As New DataObject
  Dim cbFormat As Variant
  
  Application.ScreenUpdating = False
  
  'クリップボードからDataObjectにデータを取得する
  cbData.GetFromClipboard
  
  temp = cbData.GetText
  
  'フィルター状態によって処理分岐
  If ActiveSheet.FilterMode = True Then
    ActiveSheet.ShowAllData '絞り込みクリア
  
    Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
    r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    Range(Cells(8, 3), Cells(r, 3)).Interior.Color = xlNone '塗りつぶしなし
  End If
  
  temp = Trim(temp) '先頭と末尾からスペースを削除
  Cells(7, 3).AutoFilter 5, temp '絞り込み
  
  Application.GoTo Cells(8, 1), True '絞り込み後に画面の左上セルを指定

End Sub
Attribute VB_Name = "M31_CB_Modelフィルタ"
Sub CB_Modelフィルタ()

  Dim cbData As New DataObject
  Dim cbFormat As Variant
  
  Application.ScreenUpdating = False
  
  'クリップボードからDataObjectにデータを取得する
  cbData.GetFromClipboard
  
  temp = cbData.GetText
  
  'フィルター状態によって処理分岐
  If ActiveSheet.FilterMode = True Then
    ActiveSheet.ShowAllData '絞り込みクリア
  End If
  
  temp = Trim(temp) '先頭と末尾からスペースを削除
  Cells(7, 3).AutoFilter 5, temp '絞り込み
  Cells(7, 3).AutoFilter 1, "*Model*" '絞り込み

End Sub
Attribute VB_Name = "M32_フィルタ解除"
Sub フィルタ解除()

  'フィルター状態によって処理分岐
  If ActiveSheet.FilterMode = True Then
    ActiveSheet.ShowAllData '絞り込みクリア
  End If

End Sub
Attribute VB_Name = "M33_CB文字数カウント"
Sub CB文字数カウント()

  Dim cbData As New DataObject
  Dim cbFormat As Variant
  
  On Error GoTo ErrLabel 'エラーチェック
  
  'クリップボードからDataObjectにデータを取得する
  cbData.GetFromClipboard
  
  temp = cbData.GetText
  temp_trim = Trim(temp) '先頭と末尾からスペースを削除
  
  If temp = temp_trim Then
    'コピペした文字の前後にスペースがない場合
    MsgBox "【クリップボード】" & vbCrLf & _
    temp & vbCrLf & _
    "【文字数】" & vbCrLf & _
    Len(temp)
  Else
    'コピペした文字の前後にスペースがある場合
    MsgBox "【クリップボード】" & vbCrLf & _
    temp & vbCrLf & _
    "【文字数】" & vbCrLf & _
    Len(temp) & vbCrLf & _
    "【前後の空白を削除した後の文字数】" & vbCrLf & _
    Len(temp_trim)
  End If
  
  Exit Sub
  
ErrLabel:
    MsgBox "【エラー】" & vbCrLf & "クリップボードにテキストがコピーされていません。"

End Sub
Attribute VB_Name = "M34_QACコピー"
Public QACCopy As String
Sub QACコピー()

  Dim objFSO As New FileSystemObject
  'ファイル名
  QACCopy = objFSO.GetFileName(ActiveCell.Value)

End Sub
Attribute VB_Name = "M35_QAC検索"
Sub QAC検索()

  Dim FoundCell As Range
  Dim s As String
  '↓検索文字列
  s = QACCopy
  
  If s = "" Then
    End
  End If
  
  Set FoundCell = ActiveSheet.Range("C1:C100000").SpecialCells(xlCellTypeVisible).Find(What:=s, LookAt:=xlPart)
  If Not FoundCell Is Nothing Then
    FoundCell.Activate
    FoundCell.Interior.Color = RGB(255, 255, 0) 'セル背景色
    r = ActiveCell.Row
    Range(Cells(r, 20), Cells(r, 27)).Copy
  Else
    MsgBox s & " はありませんでした。"
  End If

End Sub

Attribute VB_Name = "M36_可視セル色塗り"
Sub 可視セル色塗り()

  If (Not CopyCell2) = -1 Then
    MsgBox "配列が空です。"
    End
  End If

  Application.ScreenUpdating = False '画面更新非表示
  
  Range("C7").AutoFilter 1 'フィルタ一部解除
  
  Dim objFSO As New FileSystemObject

  a = 8 '先頭行
  B = Cells(Rows.Count, 3).End(xlUp).Row - a '選択行の数
  c = 3 '先頭列
  d = 1 '選択列の数
  rEnd = a + B
  cEnd = c + d - 1
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  Range(Cells(8, 3), Cells(r, 3)).Interior.Color = xlNone '塗りつぶしなし
  
  Dim tmp As Variant
  tmp = Range(Cells(1, 1), Cells(rEnd, cEnd + 1))
  
  For i = 1 To rEnd
    If Rows(i).Hidden = False Then
      tmp(i, cEnd + 1) = 1
    Else
      tmp(i, cEnd + 1) = 0
    End If
  Next
  
  For i = 1 To UBound(CopyCell2, 1) '配列の数分
    CopyCell2(i, 1) = objFSO.GetFileName(CopyCell2(i, 1))
  Next
  
  For i = 1 To UBound(tmp, 1) '配列の数分
    tmp(i, c) = objFSO.GetFileName(tmp(i, c))
  Next
  
  
  For i = 1 To UBound(CopyCell2, 1) '配列の数分
    For j = a To rEnd '選択範囲の行の分
  
      If tmp(j, cEnd + 1) = 1 Then '表示セル
        If CopyCell2(i, 1) = tmp(j, c) Then
          If Cells(j, c).Interior.Color = RGB(255, 255, 0) Then '既に色が塗られていた場合
            Exit For
          End If
        
          Cells(j, c).Interior.Color = RGB(255, 255, 0) 'セル背景色
        End If
      End If
      
    Next
  Next
  
  Range("C7").AutoFilter 1, RGB(255, 255, 0), xlFilterCellColor '黄色でフィルター
  Application.GoTo Cells(8, 1), True '絞り込み後に画面の左上セルを指定
  
End Sub


Attribute VB_Name = "M37_可視セルコピー2"
Public CopyCell2() As Variant

Sub 可視セルコピー2()
  Erase CopyCell2 '配列初期化

  Application.ScreenUpdating = False '画面更新非表示
  
  a = 8 '先頭行
  B = Cells(Rows.Count, 3).End(xlUp).Row - a '選択行の数
  c = 3 '先頭列
  d = 1 '選択列の数
  rEnd = a + B
  cEnd = c + d - 1
  
  Dim arrSheet()
  arrSheet = Range(Cells(1, 1), Cells(rEnd, cEnd))
  
  ReDim CopyCell2(1 To rEnd, 1 To cEnd)
  
  ct = 0
  For i = a To rEnd
  
    If Rows(i).Hidden = False Then
      ct = ct + 1
      For j = 1 To d
        CopyCell2(ct, j) = arrSheet(i, j + c - 1)
      Next
    End If
    
  Next
  
  ReDim Preserve CopyCell2(1 To rEnd, 1 To d) '二次元目を宣言し直し
  CopyCell2 = fnc_ArraySizeChange(CopyCell2, ct) '一次元目を宣言し直し

End Sub

Attribute VB_Name = "M38_コピーのみ"
Sub コピーのみ()

  '最終行
  LastRow = Cells(Rows.Count, 3).End(xlUp).Row

  'フィルター後の最上行
  LastRow = Range(Cells(8, 3), Cells(LastRow + 1, 3)).SpecialCells(xlCellTypeVisible).Areas(1).Cells(1).Row

  Range(Cells(LastRow, 20), Cells(LastRow, 27)).Copy

End Sub

Attribute VB_Name = "M39_ファイル名コピー"
'Public FNameCopy As String
Sub ファイル名コピー()

'  Dim objFSO As New FileSystemObject
'  'Dim cbData As New DataObject
'
'  'ファイル名
'  FNameCopy = objFSO.GetFileName(ActiveCell.Value)
'
'  'DataObjectにテキストを格納
'  'cbData.SetText FNameCopy
'
'  'DataObjectのデータをクリップボードに格納
'  'cbData.PutInClipboard

End Sub
Attribute VB_Name = "M40_ファイル名検索"
Sub ファイル名検索()

'課題
'①同じモジュール名 (複数発見したら一番文字数が少ないやつ)
'②コピペを配列｡文字の一部が赤色をライブラリ化
'③コード生成時のAuto変数名差分が修正ステップ数と合わない
'→ALLだったら修正ステップと合わせる

  Application.ScreenUpdating = False '画面更新非表示
  
  Dim objFSO As New FileSystemObject
  FNameCopy = objFSO.GetFileName(ActiveCell.Value)

  Dim FoundCell As Range
  Dim s As String
  '↓検索文字列
  s = FNameCopy
  s2 = ActiveCell.Offset(0, 1)
  
  If s = "" Then
    Exit Sub
  End If
  
  row1 = ActiveCell.Row
  ActiveCell.Font.Color = RGB(255, 0, 0) '文字色塗り
  Cells(row1, 11).Interior.Color = RGB(255, 255, 0) 'セル背景色
  Worksheets("比較結果_些細な変更無視").Activate
  
  Set FoundCell = ActiveSheet.Range("A1:A1048576").SpecialCells(xlCellTypeVisible).Find(What:=s, LookAt:=xlPart)
  If Not FoundCell Is Nothing Then
    FoundCell.Activate
    a = FoundCell.Row
    
    Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
    Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
    r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
    
    For i = a + 1 To r
      If VarType(Cells(i, 1)) = vbString Then
        Worksheets("ref").Cells.Clear
        Call Range(Rows(a), Rows(i - 1)).Copy(Worksheets("ref").Range("1:1")) '貼り付け
        Worksheets("ref").Activate
        Columns(2).ColumnWidth = 80
        Columns(5).ColumnWidth = 80
        Application.GoTo Reference:=Cells(1, 1), Scroll:=True
        
        Exit For
      End If
    Next
    
    
    Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
    Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
    r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列

    Dim dicA
    '辞書を作成
    Set dicA = CreateObject("Scripting.Dictionary")
        
    Dim dicB
    '値を配列に入力
    dicB = Range(Cells(1, 6), Cells(r, 6))
        
    '値をループ
    For k = 1 To UBound(dicB, 1)
        '登録されていない場合
        If dicA.Exists(dicB(k, 1)) = False And dicB(k, 1) <> "" And dicB(k, 1) <> "変更無し" _
        And Cells(k, 5).Interior.Color = RGB(255, 240, 240) Then
            dicA.Add dicB(k, 1), 0 '辞書に登録する
        End If
    Next
        
    If dicA.Count = 0 Then
      Worksheets(1).Activate
      Exit Sub
    End If
        
    'セルに値を入力
    Range("G3").Resize(dicA.Count) = WorksheetFunction.Transpose(dicA.Keys)
        
    tmp = ""
    flag = 0
    For Each Menber In dicA
      If flag = 0 Then
        tmp = Menber
        flag = 1
      Else
        tmp = tmp & "、" & Menber
      End If
    Next
        
    Cells(1, 7) = tmp
    Worksheets(1).Activate
    Cells(row1, 11) = tmp
        
    '------------------------------------
    If s2 = "モジュール外" Then
      Exit Sub
    End If
    
    Worksheets("ref").Activate
        
    Set FoundCell2 = ActiveSheet.Range("B1:B1048576").SpecialCells(xlCellTypeVisible).Find(What:=s2, LookAt:=xlPart)
    Set FoundCell3 = ActiveSheet.Range("E1:E1048576").SpecialCells(xlCellTypeVisible).Find(What:=s2, LookAt:=xlPart)
    If Not FoundCell2 Is Nothing Or Not FoundCell3 Is Nothing Then
      If FoundCell3 Is Nothing Then
        B = FoundCell2.Row
      Else
        B = FoundCell3.Row
      End If
      
      mct = 0
      rM = 2
      For j = B To r
        If Cells(j, 2) = "}" Or Cells(j, 5) = "}" Then
          rM = j
          mct = WorksheetFunction.CountIf(Range(Cells(B, 8), Cells(j, 8)), "コード生成時のAuto変数名差分")
          Exit For
        End If
      Next
            
            
      Dim dicC
      '辞書を作成
      Set dicC = CreateObject("Scripting.Dictionary")
        
      Dim dicD
      '値を配列に入力
      dicD = Range(Cells(B, 6), Cells(rM, 6))
          
      '値をループ
      For k = 1 To UBound(dicD, 1)
          '登録されていない場合
          If dicC.Exists(dicD(k, 1)) = False And dicD(k, 1) <> "" And dicD(k, 1) <> "変更無し" _
          And Cells(B + k - 1, 5).Interior.Color = RGB(255, 240, 240) Then
            If Cells(B + k - 1, 8) = "" Then 'コード生成時のAuto変数名差分は辞書登録除外
              dicC.Add dicD(k, 1), 0 '辞書に登録する
            End If
          End If
      Next
          
      If dicC.Count = 0 Then
        Worksheets(1).Activate
        Cells(row1, 11) = ""
        Exit Sub
      End If
          
      'セルに値を入力
      Range("I3").Resize(dicC.Count) = WorksheetFunction.Transpose(dicC.Keys)
          
      tmp = ""
      flag = 0
      For Each Menber In dicC
        If flag = 0 Then
          tmp = Menber
          flag = 1
        Else
          tmp = tmp & "、" & Menber
        End If
      Next
        
      Cells(1, 9) = tmp
      Worksheets(1).Activate
      Cells(row1, 11) = tmp
      Cells(row1, 12) = mct 'マンデリング
        
    End If
    
  Else
    Worksheets(1).Activate
    'MsgBox s & " はありませんでした。"
  End If


End Sub



Attribute VB_Name = "M41_BCからマンデリング抽出"
Sub BCからマンデリング抽出()

  Application.ScreenUpdating = False '画面更新非表示
  Application.Calculation = xlCalculationManual '数式計算停止
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列

  c_out = 8 '出力する列
  
  '二次元配列
  Dim tmp As Variant
  sh = Range(Cells(1, 1), Cells(r, c))
  
  'iはスタート地点が変われば修正
  fugo = ""
  For i = 2 To r
  
    Application.StatusBar = "進行状況：" & i & "/" & r
    
    If i Mod 100 = 0 Then
      DoEvents
    End If
  
    If sh(i, 3) <> Empty Then
      fugo = sh(i, 3)
    End If
    
    If fugo = "<>" Then
      oldStr = LTrim(Replace(sh(i, 2), ChrW(160), ""))
      newStr = LTrim(Replace(sh(i, 5), ChrW(160), ""))
      
      If oldStr <> Empty And newStr <> Empty Then
        If Len(oldStr) - Len(newStr) = -4 Then 'newに_xxxが増えてる場合
        
          sabun = Len(Cells(i, 5)) - Len(newStr)
        
          For j = Len(newStr) To 4 Step -1
            '後ろから文字色チェックして赤文字あったら
            
            fColor = Cells(i, 5).Characters(Start:=j + sabun, Length:=1).Font.ColorIndex
            If fColor = 3 Then
              tmp = Mid(newStr, j - 3, 4)
              If InStr(tmp, "_") >= 1 Then
                If Left(newStr, j - 4) = Left(oldStr, j - 4) Then
                  Cells(i, c_out) = "コード生成時のAuto変数名差分"
                End If
              End If
              
              Exit For
              
            End If
          Next
        
        ElseIf Len(oldStr) - Len(newStr) = 4 Then '_xxxが減ってる場合
        
          sabun = Len(Cells(i, 2)) - Len(oldStr)
        
          For j = Len(oldStr) To 4 Step -1
            '後ろから文字色チェックして赤文字あったら
            fColor = Cells(i, 2).Characters(Start:=j + sabun, Length:=1).Font.ColorIndex
            If fColor = 3 Then
              tmp = Mid(oldStr, j - 3, 4)
              If InStr(tmp, "_") >= 1 Then
                If Left(newStr, j - 4) = Left(oldStr, j - 4) Then
                  Cells(i, c_out) = "コード生成時のAuto変数名差分"
                End If
              End If
              
              Exit For
            
            End If
          Next
        
        ElseIf Len(oldStr) = Len(newStr) Then '文字数が同じ場合
        
          sabun = Len(Cells(i, 5)) - Len(newStr)
          flag = 0
          
          For j = Len(newStr) To 4 Step -1
            '後ろから文字色チェックして赤文字あったら
            oldfColor = Cells(i, 2).Characters(Start:=j + sabun, Length:=1).Font.ColorIndex
            newfColor = Cells(i, 5).Characters(Start:=j + sabun, Length:=1).Font.ColorIndex
            If newfColor = 3 Then
              oldtmp = Mid(Cells(i, 2), j + sabun - 3, 4)
              newtmp = Mid(Cells(i, 5), j + sabun - 3, 4)
              
              If InStr(oldtmp, "_") = InStr(newtmp, "_") And InStr(oldtmp, "_") >= 1 And InStr(newtmp, "_") >= 1 _
              And Len(Replace(oldtmp, "_", "")) = Len(Replace(newtmp, "_", "")) Then
                If Left(Cells(i, 2), j + sabun - 4) = Left(Cells(i, 5), j + sabun - 4) Then
                  Cells(i, c_out) = "コード生成時のAuto変数名差分"
                  flag = 0
                ElseIf InStr(Left(Cells(i, 5), j + sabun - 4), ",") >= 1 Then
                  flag = 1
                  j = j - 3
                End If
                
              End If
              
              If flag = 0 Then
                Exit For
              End If
                            
            End If
          Next
        
        End If
        
      End If
    End If
    
  Next

  Application.Calculation = xlCalculationAutomatic '数式計算再開
  Application.StatusBar = False

End Sub



Attribute VB_Name = "M42_zipに移動"
Sub zipに移動()

  tmp = Worksheets("設定").Cells(1, 2)
  fnc_SelectFileInExplorer ActiveWorkbook.Path & "\" & Left(tmp, Len(tmp) - 1) & ".zip"

End Sub
Attribute VB_Name = "M43_testフォルダを開く"
Sub testフォルダを開く()

  tmp = Worksheets("設定").Cells(1, 2)
  fPath = ActiveWorkbook.Path & "\" & Left(tmp, Len(tmp) - 1)
     
  fnc_OpenFolder (fPath)
  
End Sub

Attribute VB_Name = "M44_単体M356化"
Option Explicit

Public Const SVNパス = "C:\work\単体64ビット化\"
Private 参照設定成否フラグ              As Boolean

Sub 単体M356化()
    On Error Resume Next
    
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    
    Dim TargetBook As Workbook

        Set TargetBook = ActiveWorkbook
        
'        If TargetBook.ReadOnly Then
'            '読み取り専用のためスキップ
'
'            MsgBox "読み取り専用です。"
'        Else
            Call RefSetting(TargetBook)
            Call frmModulesUpdate(TargetBook)
            Call basModulesUpdate(TargetBook)
            'TargetBook.Save

'        End If
    
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    MsgBox "完了しました。"
    
End Sub
'********************************************
' 参照追加
'********************************************
Private Sub RefSetting(TargetBook As Workbook)
    Dim Ref As Variant
    Dim RefString() As Variant
    Dim RefDir() As Variant
    
    '64bitOSはListViewコントロールなどを読み込めないため、読み込み処理を行わない
    On Error GoTo ErrorHandler

    'Microsoft Office *** Object Library          : MSO.DLL
    '(注意)ファイル名を指定すること。DLLの名称を指定するとバージョンによって名前が変わるため。
    RefString = Array( _
        "MSO.DLL" _
    )
    '上記の参照ファイルと合わせて記述
    RefDir = Array( _
        "C:\Program Files\Common Files\Microsoft Shared\OFFICE" & CInt(Application.Version) & "\MSO.DLL" _
    )
    
    Dim i As Integer
    Dim RefCheck As Boolean
    Dim RefFullPath As Variant
    For i = 0 To UBound(RefString)
        RefCheck = False
        '参照設定の有無チェック
        For Each Ref In TargetBook.VBProject.References
            RefFullPath = Split(Ref.FullPath, "\")
            'パスを分割し最終要素がDLL名になる。
            If UCase(RefFullPath(UBound(RefFullPath))) = UCase(RefString(i)) Then
                RefCheck = True
                Exit For
            End If
        Next Ref
        
        If RefCheck Then
            '参照設定有り
        Else
            '参照設定無し
            With CreateObject("Scripting.FileSystemObject")
                'ファイルを調べる
                If .FileExists(RefDir(i)) Then
                    'ファイルが有る場合
                    TargetBook.VBProject.References.AddFromFile RefDir(i)
                    Debug.Print "[参照設定追加] "; RefString(i)
                Else
                    'ファイルが無い場合
                    MsgBox RefDir(i) & vbCrLf & "が存在しません。ファイルを追加して下さい。"
    
                End If
            End With
        End If
    Next i

    参照設定成否フラグ = True
    Exit Sub
    
ErrorHandler:
    Debug.Print "Warning：＜参照設定＞コントロールの読み込み失敗"
    参照設定成否フラグ = False
    
End Sub
'********************************************
' 標準モジュールアップデート
'********************************************
Private Sub basModulesUpdate(TargetBook As Workbook)
    Dim frmDir          As String
    
    frmDir = SVNパス
    Call ModulesImport(TargetBook, frmDir, "modEvent", "bas")

End Sub
'********************************************
' フォームモジュールアップデート
'********************************************
Private Sub frmModulesUpdate(TargetBook As Workbook)
    Dim targetModule    As VBComponent
    Dim outputPath      As String
    Dim buf             As String
    Dim f               As Object
    Dim frmDir          As String
    
    frmDir = SVNパス
    With CreateObject("Scripting.FileSystemObject")
        For Each f In .GetFolder(frmDir).Files
            'VersionInfoだけはスキップ
            If LCase(.GetExtensionName(f.Name)) = "frm" Then
                If (f.Name = "frm_VersionInfo.frm") Or _
                   (f.Name = "frm_VersionInfo.frx") Then
                   GoTo continue
                End If
                buf = .GetBaseName(f.Name)
                Call ModulesImport(TargetBook, frmDir, buf, "frm")
            End If
continue:
        Next f
    End With
    
End Sub


'********************************************
' モジュールImport Main
'********************************************
Private Sub ModulesImport(TargetBook As Workbook, パス As String, モジュール名 As String, 拡張子 As String)

    Call ModulesImportMain(TargetBook, パス, モジュール名, 拡張子)

End Sub

Public Sub ModulesImportMain(TargetBook As Workbook, パス As String, モジュール名 As String, 拡張子 As String)
    Dim targetModule        As VBComponent
    On Error GoTo ErrorHandler

    For Each targetModule In TargetBook.VBProject.VBComponents
        If (targetModule.Name = モジュール名) Then
            targetModule.Name = モジュール名 & "_old"
            TargetBook.VBProject.VBComponents.Remove targetModule
            Debug.Print "   ****** Remove: " & モジュール名
            Exit For
        End If
    Next
    
    ' Import処理
    TargetBook.VBProject.VBComponents.Import (パス & モジュール名 & "." & 拡張子)
    Debug.Print "   ****** Import: " & モジュール名
    
    Exit Sub
    
ErrorHandler:
    Debug.Print "失敗しました" & vbCrLf & モジュール名 & vbCrLf & "ファイル保存後に再実行してください", vbCritical


End Sub

Attribute VB_Name = "M45_名前の定義削除"
Sub 名前の定義削除()

  rc = MsgBox("名前の定義を削除してもよろしいですか？", vbYesNo + vbQuestion)
  
  If rc <> vbYes Then
    MsgBox "キャンセルしました。", vbCritical
    Exit Sub
  End If

  Application.ScreenUpdating = False

  Dim nm As Name
  
  On Error Resume Next
  
  ct = 0
  For Each nm In ActiveWorkbook.Names
    If Not (InStr(nm.Value, "設定!") > 0) Then
      nm.Delete
      ct = ct + 1
    End If
  Next
  
  On Error GoTo 0
  
  MsgBox ct & "個削除しました。"

End Sub
Attribute VB_Name = "M46_ツールバー作成"
Sub ツールバー作成()

  Application.ScreenUpdating = False
  
  mcr = "ツールバー作成"
  fnm = "'" & ActiveWorkbook.FullName & "'!"
  
  Application.Run (fnm & mcr)

End Sub
Attribute VB_Name = "M47_zipに圧縮"
Sub zipに圧縮()
    
  Dim targetPath As String
  Dim zipFilePath As String
  Dim psCommand As String
  Dim wsh As Object
  Dim result As Integer
  Dim kariFolder As String
  
  kariFolder = ActiveWorkbook.Path & "\" & ActiveWorkbook.Name & Format(Now, "mmhhnnss")
  
  
  'ZIP形式で圧縮するフォルダ(またはファイル)パスを指定
  tmp = Worksheets("設定").Cells(1, 2)
  targetPath = ActiveWorkbook.Path & "\" & Left(tmp, Len(tmp) - 1)
  
  'zipファイルが読み取り専用か確認
  If fnc_ExistFileCheck(targetPath & ".zip") Then
    If fnc_ReadOnlyCheck(targetPath & ".zip") Then
      MsgBox "zipファイルが読み取り専用です。" & vbCrLf & _
      "SVNでロックをして下さい。(読み取り専用が解除されます)"
      Exit Sub
    End If
  End If
  
  '作業用フォルダがなければ作成する
  If Dir(kariFolder, vbDirectory) = "" Then
    MkDir kariFolder
  End If
  
  
  '圧縮対象のフォルダがなければ終了
  If Dir(targetPath, vbDirectory) = "" Then
    MsgBox targetPath & vbCrLf & "フォルダは存在しません。"
    Exit Sub
  End If
  
  
  '作成するZIPファイルのパスを指定
  zipFilePath = kariFolder & "\" & Left(tmp, Len(tmp) - 1) & ".zip"
  
  
  'ファイルパスとZIPファイル名に対して置換処理を実行
  targetPath = ReplaceForPowerShell(targetPath)
  zipFilePath = ReplaceForPowerShell(zipFilePath)
  
  
  '実行するPowerShellのコマンドレットを組み立て
  psCommand = "powershell -NoProfile -ExecutionPolicy Unrestricted Compress-Archive -Path " & targetPath & " -DestinationPath " & zipFilePath & " -Force"
  
  Set wsh = CreateObject("WScript.Shell")
  
  'PowerShellのコマンドレットを実行
  result = wsh.Run(Command:=psCommand, WindowStyle:=1, WaitOnReturn:=True)
  
  '後片付け
  Set wsh = Nothing
  
  If result <> 0 Then
    MsgBox "圧縮に失敗しました。"
    Exit Sub
  End If
  
  '置換した名前を元に戻す
  targetPath = RestoreForPowerShell(targetPath)
  zipFilePath = RestoreForPowerShell(zipFilePath)
  
  '作業用フォルダからコピー
  FileCopy zipFilePath, targetPath & ".zip" 'コピー（上書き）
  fnc_DelFolder (kariFolder)
  
  Dim fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  newFolderName = Format(Now, "mmddhhnnss") & "_" & Mid(targetPath, InStrRev(targetPath, "\") + 1)
  
  'フォルダ名を変更
  fso.GetFolder(targetPath).Name = newFolderName
  
  newFolderFullPath = fso.GetParentFolderName(targetPath) & "\" & newFolderName
  
  'zip圧縮前フォルダを移動
  fso.MoveFolder newFolderFullPath, "C:\work\temp\単体墓場\"
  
   
  MsgBox "zipに圧縮が完了しました。"
    
End Sub

Function ReplaceForPowerShell(ByVal inputString As String) As String
    ' スペースを含む文字列をバッククォートでエスケープ
    ReplaceForPowerShell = Replace(inputString, " ", "` ")

    ' 全角スペースを含む文字列をバッククォートでエスケープ
    ReplaceForPowerShell = Replace(ReplaceForPowerShell, "　", "`　")

    ' 開きカッコをバッククォートでエスケープ
    ReplaceForPowerShell = Replace(ReplaceForPowerShell, "(", "`(")

    ' 閉じカッコをバッククォートでエスケープ
    ReplaceForPowerShell = Replace(ReplaceForPowerShell, ")", "`)")

    ' 長音記号（ー）をバッククォートでエスケープ
    ReplaceForPowerShell = Replace(ReplaceForPowerShell, "ー", "`ー")

    ' 下線記号（＿）をバッククォートでエスケープ
    ReplaceForPowerShell = Replace(ReplaceForPowerShell, "＿", "`＿")
End Function

Function RestoreForPowerShell(ByVal inputString As String) As String
    ' スペースを含む文字列をバッククォートでエスケープ
    RestoreForPowerShell = Replace(inputString, "` ", " ")

    ' 全角スペースを含む文字列をバッククォートでエスケープ
    RestoreForPowerShell = Replace(RestoreForPowerShell, "`　", "　")

    ' 開きカッコをバッククォートでエスケープ
    RestoreForPowerShell = Replace(RestoreForPowerShell, "`(", "(")

    ' 閉じカッコをバッククォートでエスケープ
    RestoreForPowerShell = Replace(RestoreForPowerShell, "`)", ")")

    ' 長音記号（ー）をバッククォートでエスケープ
    RestoreForPowerShell = Replace(RestoreForPowerShell, "`ー", "ー")

    ' 下線記号（＿）をバッククォートでエスケープ
    RestoreForPowerShell = Replace(RestoreForPowerShell, "`＿", "＿")
End Function
Attribute VB_Name = "M48_確認項目抽出"
Sub 確認項目抽出()
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  
  For i = 1 To r
    If Cells(i, 3) = "確認内容" Then
      naiyo = i
    End If
    
    If Cells(i, 3) = "確認項目" Then
      koumoku = i
    End If
    
    If Cells(i, 3) = "入力値" Then
      nyuryoku = i
      Exit For
    End If
  Next
  
  'テキストファイル出力
  'ファイルを書き込みで開く(無ければ新規作成される、あれば上書き)
  folderPath = "C:\work\temp\テキスト出力" & "\"
  fname = Format(Now, "mmhhnnss") & "_" & Cells(2, 2) & ".txt"
  
  fname = fnc_ReplaceStr(fname)
  
  Open folderPath & fname For Output As #1
   
  '開いたファイルに書き込む
  'Print #1, "確認内容"
  
  For i = naiyo To koumoku
    If Cells(i, 4) <> "" Then
      Print #1, Cells(i, 4).Value & "    " & Cells(5, 6)
    End If
  Next
  
  Print #1, ""
  'Print #1, "確認項目"
  
  For i = koumoku To nyuryoku - 1
    If Cells(i, 4) <> "" Then
      Print #1, Cells(i, 4).Value & "：" & Cells(i, 5).Value
    End If
    
    If Cells(i, 4) = "" And Cells(i, 5) <> "" Then
      Print #1, "  " & Cells(i, 5).Value
    End If
  Next
   
  '開いたファイルを閉じる
  Close #1
  
  fnc_OpenText (folderPath & fname)

End Sub

Attribute VB_Name = "M49_コメント抽出"
Sub コメント抽出(sWord As String)
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行

  For i = 1 To r
    If Cells(i, 3) = sWord Then '入力値 or 期待値（確認値）
      tmp = i
      Exit For
    End If
  Next

  c = Cells(tmp + 1, Columns.Count).End(xlToLeft).Column '一番右の列
  c2 = Cells(tmp, Columns.Count).End(xlToLeft).Column '一番右の列

  For j = 5 To c
    If Not Cells(tmp + 1, j).Comment Is Nothing Then
      sCmnt = Cells(tmp + 1, j).Comment.Text
      arrS = Split(sCmnt, vbCrLf)
      
      '[]削除
      If Left(arrS(0), 1) = "[" Then
        arrS(0) = fnc_DelBracket(arrS(0), "[", "]")
      End If
      
      Cells(tmp, j) = arrS(0) '1行目
    End If
  Next
  
  Range(Cells(tmp, 5), Cells(tmp, c2)).Font.Size = 10   'フォントサイズ
  Range(Cells(tmp, 5), Cells(tmp + 1, c)).WrapText = True '折り返して全体表示
  Range(Cells(tmp, 5), Cells(tmp, c2)).Borders.LineStyle = xlContinuous   'セル罫線

End Sub
Attribute VB_Name = "M50_画面固定"
Sub 画面固定(sWord As String)
  
  ActiveWindow.FreezePanes = False 'ウィンドウ枠固定
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行

  For i = 1 To r
    If Cells(i, 3) = sWord Then '入力値 or 期待値（確認値）
      tmp = i
      Exit For
    End If
  Next

  c = Cells(tmp + 1, Columns.Count).End(xlToLeft).Column '一番右の列
  
  Application.GoTo Reference:=Cells(tmp, 3), Scroll:=True '画面左上位置調整
  Cells(tmp + 2, 5).Select
  ActiveWindow.FreezePanes = True 'ウィンドウ枠固定
  Range(Cells(tmp + 2, 3), Cells(tmp + 2, c)).Font.Bold = True '太字
  
End Sub
Attribute VB_Name = "M51_パターンチェック"
Sub パターンチェック()

  Call fnc_st
  
  Call コメント抽出("入力値")
  Call 画面固定("入力値")
  Call コメント幅調整
  
  Call fnc_end

End Sub
Attribute VB_Name = "M52_パターン_ハイライト"
Sub パターン_ハイライト()

  Call fnc_st
  
  mcr = "入力ハイライト選択"
  fnm = "'" & ActiveWorkbook.FullName & "'!"
  Application.Run (fnm & mcr)
  
  Call コメント抽出("期待値（確認値）")
  Call 画面固定("期待値（確認値）")
  Call コメント幅調整
  
  Call fnc_end


End Sub
Attribute VB_Name = "M53_stop作成"
Sub Stop作成()

  '※DataObjectは参照設定「Microsoft Forms 2.0 Object Library」が必要。

  Dim CB As New DataObject
  Dim tmp As String
  
  Call fnc_st
  
  With Worksheets("DataBase")
    Dummy = .UsedRange.Row '終端セル誤認バグ修正
    Dummy = .UsedRange.Column '終端セル誤認バグ修正
    r = .Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    c = .Range("A1").SpecialCells(xlLastCell).Column '一番右の列
    
    For i = 2 To r
      If ActiveSheet.Name = .Cells(i, 1) Then
        templateName = .Cells(i, 4)
        Exit For
      End If
    Next
  End With
  
  With Worksheets("設定")
    Dummy = .UsedRange.Row '終端セル誤認バグ修正
    Dummy = .UsedRange.Column '終端セル誤認バグ修正
    r = .Range("A1").SpecialCells(xlLastCell).Row '一番下の行
    c = .Range("A1").SpecialCells(xlLastCell).Column '一番右の列
    
    For i = 13 To r
      If templateName = .Cells(i, 1) Then
        testCycle = .Cells(i, 3)
        Exit For
      End If
    Next
  End With
  
  checkTime = Cells(Selection.Row, 4)
  n = checkTime / testCycle
  
  Dim f As String
  f = str(checkTime)
    
  tmp = "If time = " & n & " Then Stop 'time：" & checkTime & "を確認"
  
  Call fnc_ClipBoardSave(tmp, True)

  Call fnc_end
  
End Sub


Attribute VB_Name = "M54_CBにコピー"
Sub CBにコピー()
  'ActiveCell.Offset(1, 0).Select
  
  Dim tmp As String
  
  tmp = ActiveCell.Value
'  tmp = Right(tmp, Len(tmp) - InStr(tmp, ".") - 1) 'カバレッジ用
  
  
  Call fnc_ClipBoardSave(tmp)


End Sub
Attribute VB_Name = "M55_ハイライト転記"
Sub ハイライト転記()

  fnc_st
  Call fnc_rc(r, c)
  
  For i = 1 To r
    If Cells(i, 3) = "入力値" Then
      inp = i
    End If
  
    If Cells(i, 3) = "期待値（確認値）" Then
      kitai = i
      Exit For
    End If
  Next

  c2 = Cells(kitai + 1, Columns.Count).End(xlToLeft).Column '期待値の一番右の列
  r2 = Cells(kitai, 3).End(xlDown).Row '期待値の一番下の行
  
  SearchWord = Cells(kitai + 1, Selection.Column)
  
  For i = 5 To c
    If SearchWord = Cells(inp + 1, i) Then
      SearchWord_c = i
      Exit For
    End If
  Next
  
  j = 0
  For i = kitai + 2 To r2
    Cells(inp + 2 + j, SearchWord_c) = Cells(i, Selection.Column).Value
    j = j + 1
  Next
  
  fnc_end
  
  MsgBox SearchWord & " を反映しました。"

End Sub
Attribute VB_Name = "M56_パターン_修正"
Sub パターン修正()

  fnc_st
  Call fnc_rc(r, c)
  
  'シートを二次元配列に格納
  Dim tmp As Variant
  tmp = Range(Cells(1, 1), Cells(r, c))
  
  For i = 1 To r
    If tmp(i, 3) = "入力値" Then
      inp = i
    End If
  
    If tmp(i, 3) = "期待値（確認値）" Then
      kitai = i
      Exit For
    End If
  Next

  r2 = Cells(inp, 3).End(xlDown).Row '入力値の一番下の行
  c2 = Cells(inp + 1, Columns.Count).End(xlToLeft).Column '入力値の一番右の列
  r3 = Cells(kitai, 3).End(xlDown).Row '期待値の一番下の行
  c3 = Cells(kitai + 2, Columns.Count).End(xlToLeft).Column '期待値の一番右の列
  
  Call コメント抽出("期待値（確認値）")
  
  Dim tmp2() As Variant
  ReDim Preserve tmp2(1 To r3 - kitai + 1, 1 To c3 - 4)

  For i = kitai To r3
  
    For j = 5 To c3
      If i = kitai And (c3 - 5) / 2 <= j - 5 Then
        If j <> c3 Then
          jStr = fnc_ColumnIdx2Name(j - (c3 - 5) / 2)
          tmp2(i - kitai + 1, j - 4) = "=" & jStr & i
        End If
      Else
        jStr = fnc_ColumnIdx2Name(j)
        tmp2(i - kitai + 1, j - 4) = "=" & jStr & i

        If i = kitai + 1 Then
          If Not Cells(i, j).Comment Is Nothing Then 'コメントがあるとき
            Cells(inp + 1, c2 + j - 3).AddComment Cells(i, j).Comment.Text
          End If
        End If
        
      End If
    Next
    
  Next
  
  Range(Cells(inp, c2 + 2), Cells(r2, c2 + 2 + c3 - 5)) = tmp2
  Range(Cells(inp, c2 + 2), Cells(r2, c2 + 2 + c3 - 5)).Borders.LineStyle = xlContinuous  'セル罫線
  Range(Cells(inp, c2 + 2), Cells(r2, c2 + 2 + c3 - 5)).HorizontalAlignment = xlCenter
  Range(Cells(inp + 2, c2 + 2), Cells(r2, c2 + 1 + (c3 - 5) / 2)).Interior.Color = RGB(255, 153, 204) 'セル背景色
  Range(Cells(inp, c2 + 2), Cells(inp + 1, c2 + 1 + (c3 - 5) / 2)).Interior.Color = RGB(153, 204, 255)  'セル背景色
  Range(Cells(inp, c2 + 2 + (c3 - 5) / 2), Cells(inp + 1, c2 + 2 + c3 - 6)).Interior.Color = RGB(0, 204, 255)  'セル背景色
  Columns(c2 + 1).ColumnWidth = 2
  
  For i = 5 To c2
    If Cells(inp + 2, i).Interior.Color <> RGB(255, 255, 0) Then
      Columns(i).Hidden = True  '列を非表示
    End If
  Next
  
  Call コメント抽出("入力値")
  Call 画面固定("入力値")
  Call コメント幅調整
    
  fnc_end

End Sub
Attribute VB_Name = "M57_zip更新日付確認"
Sub zip更新日付確認()

  Dim filePath As String
  Dim zipFileTimeStamp As Date
  Dim zipFolderTimeStamp As Date
  Dim fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  
  zipFolderName = Left(Worksheets("設定").Cells(1, 2), Len(Worksheets("設定").Cells(1, 2)) - 1)
  zipFileName = zipFolderName & ".zip"
  
  zipFolderPath = ActiveWorkbook.Path & "\" & zipFolderName
  zipFilePath = ActiveWorkbook.Path & "\" & zipFileName

    
  Dim fl As Folder
  Set fl = fso.GetFolder(zipFolderPath) ' フォルダを取得
  
  zipFileTimeStamp = FileDateTime(zipFilePath) 'ファイルの更新日時を取得
  zipFolderTimeStamp = fl.DateLastModified 'フォルダの更新日時を取得
  
  If zipFileTimeStamp > zipFolderTimeStamp Then
    MsgBox "zipファイルの更新日時　 ：" & zipFileTimeStamp & vbCrLf & _
    "テストフォルダの更新日時：" & zipFolderTimeStamp & vbCrLf & vbCrLf & _
    "古いテストフォルダで試験をしている可能性があります。"
  Else
    MsgBox "zipファイルの更新日時　 ：" & zipFileTimeStamp & vbCrLf & _
    "テストフォルダの更新日時：" & zipFolderTimeStamp & vbCrLf & vbCrLf & _
    "問題なし。"
  End If
  
End Sub
Attribute VB_Name = "M58_テンプレ名取得"
Sub テンプレ名取得()

  tgtStr = Cells(ActiveCell.Row, 7).Formula
  

  RowNo = ""
  For i = Len(tgtStr) To 1 Step -1
      chkStr = Mid(tgtStr, i, 1)
      If IsNumeric(chkStr) = True Then  'i文字目が数値なら
        RowNo = chkStr & RowNo
      Else
        Exit For
      End If
  Next

  If IsNumeric(RowNo) = True Then
    MsgBox Worksheets("DataBase").Cells(RowNo, 1) & vbCrLf & _
    Worksheets("DataBase").Cells(RowNo, 2) & vbCrLf & _
    Worksheets("DataBase").Cells(RowNo, 3) & vbCrLf & _
    Worksheets("DataBase").Cells(RowNo, 4)
  End If


End Sub
Attribute VB_Name = "M59_出力mファイル化"
Sub 出力mファイル化()

  fnc_st
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  
  OutRowEnd = Cells(Rows.Count, 8).End(xlUp).Row
  
  Dim arr As Variant
  arr = Range(Cells(1, 1), Cells(r, c))
  
  If arr(1, 8) = "出力値" And arr(1, 9) = "出力モデル型" And arr(1, 10) = "出力Value" And _
    arr(1, 11) = "出力意味" And arr(1, 12) = "出力コメント" Then
    
    
    'テキストファイル出力
    'ファイルを書き込みで開く(無ければ新規作成される、あれば上書き)
    folderPath = "C:\work\temp\テキスト出力" & "\"
    fname = Format(Now, "mmhhnnss") & "_" & "出力値" & ".txt"
    
    fname = fnc_ReplaceStr(fname)
    
    Open folderPath & fname For Output As #1
    
    For i = 2 To OutRowEnd
    
      dType = ""
      If arr(i, 9) = "int8" Then
        dType = "s1M"
      ElseIf arr(i, 9) = "int16" Then
        dType = "s2M"
      ElseIf arr(i, 9) = "int32" Then
        dType = "s4M"
      ElseIf arr(i, 9) = "uint8" Then
        dType = "u1M"
      ElseIf arr(i, 9) = "uint16" Then
        dType = "u2M"
      ElseIf arr(i, 9) = "uint32" Then
        dType = "u4M"
      ElseIf arr(i, 9) = "boolean" Then
        dType = "bM"
      End If
      
      Print #1, arr(i, 8) & "=" & dType & "_" & Worksheets(1).Name & "_" & arr(i, 8) & ";"
    Next

    '開いたファイルを閉じる
    Close #1
    
    fnc_OpenText (folderPath & fname)
  
  End If
  
  fnc_end
  

End Sub
Attribute VB_Name = "M60_検索設定"
Sub 検索設定()

  '検索条件をリセット
  Set rngFind = Range("A1:A2").Find(What:="", _
                                LookIn:=xlValues, _
                                LookAt:=xlPart, _
                                SearchOrder:=xlByColumns, _
                                SearchDirection:=xlNext, _
                                MatchCase:=False, _
                                MatchByte:=False)
                                
  '検索BOX表示
  Application.CommandBars.FindControl(ID:=1849).Execute

End Sub





 

Attribute VB_Name = "M61_検索"
Private counter As Long
Private before_x As Long
Private before_y As Long
Private before_ws As String
Private strIn As String
Private before_strIn As String

Sub 文字検索()

'  If counter = 0 Then
'    strIn = InputBox("検索する単語を入力して下さい。")
'  End If
'
'  If strIn = "" Then
'    Exit Sub
'  End If

  Dim cbData As New DataObject
  Dim cbFormat As Variant
  
  On Error GoTo ErrLabel 'エラーチェック
  
  'クリップボードからDataObjectにデータを取得する
  cbData.GetFromClipboard
  strIn = cbData.GetText
  
  On Error GoTo 0 '通常通りエラーが発生すれば停止
  
  If strIn <> before_strIn Then
    counter = 0
  End If

  fnc_st
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  
  c = 5 '★今回の作業のみ
  
  If r = 1 And c = 1 Then
    counter = 0
    fnc_end
    Exit Sub
  End If
  
  Dim arr As Variant
  arr = Range(Cells(1, 1), Cells(r, c))
  
  ctflag = 1
  For x = 1 To r
    For y = 1 To c
  
      '前回の続きのセルから検索
      If counter <> 0 And ctflag = 1 Then
        If before_ws = ActiveSheet.Name Then
        
          If before_y = c Then '最終列まで行った場合
            x = before_x + 1
            y = 1
          Else
            x = before_x
            y = before_y + 1
          End If
        
        Else
          counter = 0
        End If
        
        ctflag = 0
      End If
      
      If InStr(arr(x, y), strIn) > 0 Then
        If x >= 2 Then
          Application.GoTo Reference:=Cells(x - 2, 1), Scroll:=True
        Else
          Application.GoTo Reference:=Cells(x, 1), Scroll:=True
        End If
        Cells(x, y).Activate
        counter = counter + 1
        before_x = x
        before_y = y
        before_ws = ActiveSheet.Name
        before_strIn = strIn
        fnc_end
        Exit Sub
      End If
  
    Next
  Next

  fnc_end
  
  If counter = 0 Then
    MsgBox "「" & strIn & "」" & vbCrLf & "はありませんでした。"
  Else
    MsgBox "「" & strIn & "」" & vbCrLf & "はこれ以上ありません。" & vbCrLf & counter & "箇所です。"
  End If
  
  counter = 0
  
  Exit Sub
  
ErrLabel:
  MsgBox "【エラー】" & vbCrLf & "クリップボードにテキストがコピーされていません。"
  
End Sub


Attribute VB_Name = "M62_文字二重"
Sub 文字二重()

  Dim cbData As New DataObject
  Dim cbFormat As Variant
  Dim tmp_w As String
  
  On Error GoTo ErrLabel 'エラーチェック
  
  'クリップボードからDataObjectにデータを取得する
  cbData.GetFromClipboard
  
  '念のため2回
  cbData.GetFromClipboard
  
  tmp = cbData.GetText
  tmp_trim = Trim(tmp) '先頭と末尾からスペースを削除
  
  tmp_w = ""
  For i = 1 To Len(tmp_trim)
  
    For j = 1 To 2
      tmp_w = tmp_w & Mid(tmp_trim, i, 1)
    Next
    
  Next
  
  Call fnc_ClipBoardSave(tmp_w)
  
  '1秒後自動で閉じる
  Set wsh = CreateObject("WScript.Shell")
  wsh.Popup tmp_w, 1, "Title", vbInformation
  Set wsh = Nothing
  
  Exit Sub
  
ErrLabel:
    MsgBox "【エラー】" & vbCrLf & "クリップボードにテキストがコピーされていません。"


End Sub
Attribute VB_Name = "M90_RibbonとcustomUI作成"
'★参照設定
'Visual Basic For Applications
'Microsoft Excel 16.0 Object Library
'OLE Automation
'Microsoft Office 16.0 Object Library
'Microsoft Forms 2.0 Object Library → 参照からC:\windows\system32\FM20.DLL
'Microsoft ActiveX Data Objects 2.8 Library
'Microsoft Visual Basic for Application Extensibilly 5.3
'Microsoft Scripting Runtime
'★初期設定
'開発タブ→コード→マクロのセキュリティ
'「VBAプロジェクトオブジェクトモデルへのアクセスを信頼する(V)」にチェック


Sub Ribbon作成()

'参照設定「Microsoft ActiveX Data Object X.X Library」にチェックを入れる。(UTF-8でテキスト保存)

  '■■■RibbonとRibbon作成以外のSubを格納■■■
  Dim mySub() As Variant
  ReDim mySub(1 To 2, 1 To 1)
  
  j = 0
  With ActiveWorkbook.VBProject
    For i = 1 To .VBComponents.Count
      If .VBComponents(i).Type = 1 And .VBComponents(i).Name <> "M90_RibbonとcustomUI作成" _
      And .VBComponents(i).Name <> "M91_Ribbon" And .VBComponents(i).Name <> "M99_myFunction" _
      And .VBComponents(i).Name <> "M92_一括エクスポート" And .VBComponents(i).Name <> "M93_一括インポート" _
      And .VBComponents(i).Name <> "M94_ユーザーフォーム抽出" And .VBComponents(i).Name <> "M95_ユーザーフォーム作成" _
      And .VBComponents(i).Name <> "M96_Moduleインポート" Then
        For k = 1 To .VBComponents(i).CodeModule.CountOfLines '名前を格納
          code = .VBComponents(i).CodeModule.Lines(k, 1)
          If InStr(code, "Sub") <> 0 Then
            j = j + 1
            ReDim Preserve mySub(1 To 2, 1 To j)
            code = Mid(code, InStr(code, "Sub") + 4)
'            code = Left(code, InStr(code, "(") - 1)
            mySub(1, j) = UCase(.VBComponents(i).Name) 'バグって大文字と小文字が混在することがあったので大文字で統一
            mySub(2, j) = code
            Exit For
          End If
        Next
        
      End If
    Next
  End With
  
  'D列誤記対策
  For i = 1 To j
    k = 3
    flag = 1
    Do While Cells(k, 4) <> ""
      'If mySub(2, i) = Cells(k, 4) Then
      tmp = Left(mySub(2, i), InStr(mySub(2, i), "(") - 1)
      If tmp = Cells(k, 4) Then
        flag = 0
        Exit Do
      End If
      
      k = k + 1
    Loop
    
    If flag = 1 Then
      MsgBox "「" & tmp & "」がD列に存在しません。"
      End
    End If
  Next
  
  
  mySub = fnc_arrTranspose(mySub) '行列を入れ替える
  Call クイックソート(mySub, LBound(mySub), UBound(mySub), 1)

  '■■■Ribbon用のコードを格納■■■
  
  mycode = "'ここは「Ribbon作成」により自動で作成されるので編集不要です" & vbCrLf & _
  "Public Sub R_ShowMsg(control As IRibbonControl)" & vbCrLf & vbCrLf & _
  "Select Case control.ID" & vbCrLf
  
  For i = 1 To j
  
    tmp = Left(mySub(i, 2), InStr(mySub(i, 2), "(") - 1)
    If InStr(mySub(i, 2), "()") > 0 Then
      mycode = mycode & "Case ""Button" & i & """: Call " & tmp & vbCrLf
    Else
      mycode = mycode & "Case ""Button" & i & """: Call " & tmp & "("""")" & vbCrLf
    End If
    
    mySub(i, 2) = Left(mySub(i, 2), InStr(mySub(i, 2), "(") - 1)
  Next
  
  mycode = mycode & "End Select" & vbCrLf & vbCrLf & "End Sub"
  
  myLine = 5
  With ThisWorkbook.VBProject.VBComponents("M91_Ribbon").CodeModule
    .DeleteLines 1, .CountOfLines 'モジュール内のコード全て削除
    .AddFromString mycode
    
    .ReplaceLine myLine - 1, vbTab & .Lines(myLine - 1, 1) 'Tabをいい感じに挿入
    For i = myLine To j + myLine - 1
      .ReplaceLine i, vbTab & vbTab & .Lines(i, 1)
    Next
     .ReplaceLine i, vbTab & .Lines(i, 1)
  End With
  
  Call A1セルに移動
       
  '■■■ブックを保存■■■
  Application.DisplayAlerts = False ' メッセージを非表示
  
  backup_fPath = "C:\Users\10035690229\Desktop\01_root\マクロ\エクセルアドイン\Menuバックアップ"
  backup_fName = Format(Now, "yyyymmddhhnnss") & "_" & ThisWorkbook.Name
  
  fPath = ThisWorkbook.Path
  fname = ThisWorkbook.Name
  
  'フォルダがなければ作成する
  If Dir(backup_fPath, vbDirectory) = "" Then
    MkDir backup_fPath
  End If
  
  'バックアップファイルを保存
  ActiveWorkbook.SaveAs Filename:=backup_fPath & "\" & backup_fName, FileFormat:=xlOpenXMLWorkbookMacroEnabled
  '元ファイルを上書き保存
  ActiveWorkbook.SaveAs Filename:=fPath & "\" & fname, FileFormat:=xlOpenXMLWorkbookMacroEnabled
  
  Application.DisplayAlerts = True  ' メッセージを表示
  
  
  Call customUI作成(mySub)
       
End Sub

Sub クイックソート(ByRef argAry() As Variant, _
               ByVal lngMin As Long, _
               ByVal lngMax As Long, _
               ByVal keyPos As Long)
  Dim i As Long
  Dim j As Long
  Dim k As Long
  Dim vBase As Variant
  Dim vSwap As Variant
  vBase = argAry(Int((lngMin + lngMax) / 2), keyPos)
  i = lngMin
  j = lngMax
  Do
    Do While argAry(i, keyPos) < vBase
      i = i + 1
    Loop
    Do While argAry(j, keyPos) > vBase
      j = j - 1
    Loop
    If i >= j Then Exit Do
    For k = LBound(argAry, 2) To UBound(argAry, 2)
      vSwap = argAry(i, k)
      argAry(i, k) = argAry(j, k)
      argAry(j, k) = vSwap
    Next
    i = i + 1
    j = j - 1
  Loop
  If (lngMin < i - 1) Then
    Call クイックソート(argAry, lngMin, i - 1, keyPos)
  End If
  If (lngMax > j + 1) Then
    Call クイックソート(argAry, j + 1, lngMax, keyPos)
  End If
End Sub

Public Function customUI作成(mySub_label As Variant) As Variant
    
  Dim filePath As String

  Dim mygroup_Label() As String
  ReDim mygroup_Label(0)
  
  Dim mylabel() As String
  ReDim mylabel(0)
  
  Dim myimageMso() As String
  ReDim myimageMso(0)
  
  Dim mysize() As String
  ReDim mysize(0)
  
  mytab = "Tool" 'ハンド
  mygroup_Label(0) = "全シート対象" '後で自動抽出にする
  mylabel(0) = "A1セルに移動" '後で自動抽出にする
  myimageMso(0) = ""
  mysize(0) = ""
  
  Application.ScreenUpdating = False
  
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
      
  '作成するファイルパスを指定
  filePath = ThisWorkbook.Path & "\customUI.xml"
  
  If Dir(filePath) <> "" Then
    Kill filePath 'ファイル削除
  End If
  
  'テキストファイルを作成
  Dim stm As ADODB.Stream
  Set stm = New ADODB.Stream
  stm.Charset = "UTF-8"
  stm.Open
  
  'タブを格納
  mytab = Cells(3, 1)
  
  'グループ名称を格納
  Dim mygroup() As String
  ReDim mygroup(0)
  
  ct = 0
  syokai_flag = 1
  For i = 3 To r
    NG_flag = 0
  
    If Cells(i, 2) = 1 Then
    
      If syokai_flag = 1 Then
        mygroup(0) = Cells(i, 3)
        syokai_flag = 0
      Else
        For j = 0 To UBound(mygroup)
          If mygroup(j) = Cells(i, 3) Then
            NG_flag = 1
          End If
        Next
      
        If NG_flag = 0 Then
          ct = ct + 1
          ReDim Preserve mygroup(ct)
          mygroup(ct) = Cells(i, 3)
        End If
      End If
      
    End If
    
  Next
  
  
  '書き込み ※改行あり
  
  stm.WriteText "<?xml version=""1.0"" encoding=""utf-8""?>", 1
  stm.WriteText "<customUI xmlns=""http://schemas.microsoft.com/office/2006/01/customui"">", 1
  stm.WriteText "    <ribbon startFromScratch=""false"">", 1
  stm.WriteText "      <tabs>"
  stm.WriteText "        <tab id=""Tab"" label=""" & mytab & """>", 1

  For i = 0 To UBound(mygroup)
    stm.WriteText "            <group id=""" & "g" & i + 1 & """ label=""" & mygroup(i) & """>", 1
    
    For j = 3 To r
      If Cells(j, 2) = 1 And Cells(j, 3) = mygroup(i) Then
        For k = 1 To UBound(mySub_label, 1)
          If Cells(j, 4) = mySub_label(k, 2) Then
            No = k
            Exit For
          End If
        Next
      
        stm.WriteText "                <button id=""Button" & No & """ label=""" & Cells(j, 4) & """ imageMso=""" & Cells(j, 5) & """ size=""" & Cells(j, 6) & """ onAction=""R_ShowMsg"" />", 1
      End If
    Next
    
    stm.WriteText "            </group>", 1

  Next
  
  stm.WriteText "        </tab>", 1
  stm.WriteText "      </tabs>", 1
  stm.WriteText "    </ribbon>", 1
  stm.WriteText "</customUI>", 1
  
  
  'テキストファイルを閉じる
  stm.SaveToFile filePath
  stm.Close

  '後片付け
  Set stm = Nothing
  
  MsgBox "完了しました。"
   
End Function
Attribute VB_Name = "M91_Ribbon"
'ここは「Ribbon作成」により自動で作成されるので編集不要です
Public Sub R_ShowMsg(control As IRibbonControl)

  Select Case control.ID
    Case "Button1": Call A1セルに移動
    Case "Button2": Call シート表示倍率変更
    Case "Button3": Call シート再表示
    Case "Button4": Call 行色塗り
    Case "Button5": Call 列色塗り
    Case "Button6": Call 大文字小文字変換
    Case "Button7": Call CSV出力
    Case "Button8": Call 列幅自動調整
    Case "Button9": Call コメント幅調整
    Case "Button10": Call 文字色塗り
    Case "Button11": Call 赤文字チェック
    Case "Button12": Call OK_NG強調表示
    Case "Button13": Call 語尾修正
    Case "Button14": Call 語尾赤色
    Case "Button15": Call シート比較
    Case "Button16": Call 図形文字削除
    Case "Button17": Call 文字修正
    Case "Button18": Call 可視セルコピー
    Case "Button19": Call 可視セル貼り付け
    Case "Button20": Call グループで色塗り
    Case "Button21": Call 列幅コピー
    Case "Button22": Call 列幅貼り付け
    Case "Button23": Call 文字数カウント
    Case "Button24": Call 文字で背景色1
    Case "Button25": Call 文字で背景色2
    Case "Button26": Call 文字で背景色3
    Case "Button27": Call ラベル_単体
    Case "Button28": Call ラベル_カバレッジ
    Case "Button29": Call テキストボックス検索
    Case "Button30": Call CBフィルタ
    Case "Button31": Call CB_Modelフィルタ
    Case "Button32": Call フィルタ解除
    Case "Button33": Call CB文字数カウント
    Case "Button34": Call QACコピー
    Case "Button35": Call QAC検索
    Case "Button36": Call 可視セル色塗り
    Case "Button37": Call 可視セルコピー2
    Case "Button38": Call コピーのみ
    Case "Button39": Call ファイル名コピー
    Case "Button40": Call ファイル名検索
    Case "Button41": Call BCからマンデリング抽出
    Case "Button42": Call zipに移動
    Case "Button43": Call testフォルダを開く
    Case "Button44": Call 単体M356化
    Case "Button45": Call 名前の定義削除
    Case "Button46": Call ツールバー作成
    Case "Button47": Call zipに圧縮
    Case "Button48": Call 確認項目抽出
    Case "Button49": Call コメント抽出("")
    Case "Button50": Call 画面固定("")
    Case "Button51": Call パターンチェック
    Case "Button52": Call パターン_ハイライト
    Case "Button53": Call Stop作成
    Case "Button54": Call CBにコピー
    Case "Button55": Call ハイライト転記
    Case "Button56": Call パターン修正
    Case "Button57": Call zip更新日付確認
    Case "Button58": Call テンプレ名取得
    Case "Button59": Call 出力mファイル化
    Case "Button60": Call 検索設定
    Case "Button61": Call 文字検索
    Case "Button62": Call 文字二重
  End Select

End Sub
Attribute VB_Name = "M92_一括エクスポート"
Sub 一括エクスポート()
    Dim module                  As VBComponent      '// モジュール
    Dim moduleList              As VBComponents     '// VBAプロジェクトの全モジュール
    Dim extension                                   '// モジュールの拡張子
    Dim sPath                                       '// 処理対象ブックのパス
    Dim sFilePath                                   '// エクスポートファイルパス
    Dim TargetBook                                  '// 処理対象ブックオブジェクト
    
    Set TargetBook = ActiveWorkbook
    
    sPath = fnc_MakeFolder(TargetBook.Path, Format(Date, "yyyymmdd"))
    
    '// 処理対象ブックのモジュール一覧を取得
    Set moduleList = TargetBook.VBProject.VBComponents
    
    '// VBAプロジェクトに含まれる全てのモジュールをループ
    For Each module In moduleList
'        '// クラス
'        If (module.Type = vbext_ct_ClassModule) Then
'            extension = "cls"
'        '// フォーム
'        ElseIf (module.Type = vbext_ct_MSForm) Then
'            '// .frxも一緒にエクスポートされる
'            extension = "frm"
        '// 標準モジュール
        If (module.Type = vbext_ct_StdModule) Then
            extension = "bas"
        '// その他
        Else
            '// エクスポート対象外のため次ループへ
            GoTo continue
        End If
        
        Mxx_Name = UCase(Left(module.Name, 1)) & Mid(module.Name, 2)
        
        '// エクスポート実施
        sFilePath = sPath & "\" & Mxx_Name & "." & extension
        Call module.Export(sFilePath)
        
        '// 出力先確認用ログ出力
        Debug.Print sFilePath
continue:
    Next
    
    
  '■MargeTextFile.vbs出力
  'ファイルを書き込みで開く(無ければ新規作成される、あれば上書き)
  Open sPath & "\MargeTextFile.vbs" For Output As #1
  
  '開いたファイルに書き込む
  Print #1, "if WScript.Arguments.Count>1 Then"
  Print #1, "  Dim FSO"
  Print #1, "  Set FSO = WScript.CreateObject(""Scripting.FileSystemObject"")"
  Print #1, "  Dim sMarge"
  Print #1, "  For i=0 To WScript.Arguments.Count-1"
  Print #1, "    Dim oArg"
  Print #1, "    oArg=WScript.Arguments.Item(i)"
  Print #1, "    If FSO.FileExists(oArg) Then"
  Print #1, "      Dim oFs"
  Print #1, "      Set oFs=FSO.GetFile(oArg).OpenAsTextStream"
  Print #1, "      sMarge=sMarge & oFs.ReadAll"
  Print #1, "    End If"
  Print #1, "  Next"
  Print #1, "  Dim oMrg"
  Print #1, "  Set oMrg=FSO.OpenTextFile(fso.getParentFolderName(WScript.ScriptFullName) & ""\Marge.txt"",2,True)"
  Print #1, "  oMrg.Write sMarge"
  Print #1, "  oMrg.Close"
  Print #1, "End If"

  '開いたファイルを閉じる
  Close #1
  
  
  '■SplitTextFile.vbs出力
  'ファイルを書き込みで開く (無ければ新規作成される､あれば上書き)
  Open sPath & "\SplitTextFile.vbs" For Output As #1
  
  '開いたファイルに書き込む
  Print #1, "arg         = WScript.Arguments(0)"
  Print #1, "Set objFSO  = WScript.CreateObject(""Scripting.FileSystemObject"")"
  Print #1, "Set objFile = objFSO.OpenTextFile(arg)"
  Print #1, "lineCount = 0"
  Print #1, "fName   = """""
  Print #1, "flag = 1"
  Print #1, "path = objFSO.getParentFolderName(WScript.ScriptFullName) & ""\"""
  Print #1, ""
  Print #1, "Do While objFile.AtEndOfStream <> True "
  Print #1, ""
  Print #1, "    rbuf = objFile.ReadLine"
  Print #1, "    If lineCount <> 0 and InStr(rbuf, ""Attribute VB_Name = "") <> 0 And InStr(rbuf, """"""Attribute VB_Name = "") = 0 Then"
  Print #1, "        newFile.Close"
  Print #1, "        flag = 1"
  Print #1, "    End If"
  Print #1, ""
  Print #1, "    If flag = 1 Then"
  Print #1, "        fName = Mid(rbuf, InStr(rbuf, ""="") + 3)"
  Print #1, "        fName = Left(fName, Len(fName) - 1)"
  Print #1, "        Set newFile = objFSO.CreateTextFile(path & fName & "".bas"", true)"
  Print #1, "        flag = 0"
  Print #1, "    End If"
  Print #1, ""
  Print #1, "    lineCount = lineCount + 1"
  Print #1, ""
  Print #1, "    If InStr(rbuf, ""Attribute VB_Name = """"m"") <> 0 Then"
  Print #1, "        rbuf = Replace(rbuf, ""Attribute VB_Name = """"m"", ""Attribute VB_Name = """"M"")"
  Print #1, "    End If"
  Print #1, ""
  Print #1, "    newFile.WriteLine(rbuf)"
  Print #1, ""
  Print #1, "Loop"
  Print #1, ""
  Print #1, "newFile.Close"
  Print #1, "objFile.Close"
  Print #1, "Set objFile = Nothing"
  Print #1, "Set objFSO  = Nothing"
  Print #1, "Set newFile = Nothing"
  
  '開いたファイルを閉じる
  Close #1
  
  MsgBox "エクスポートが完了しました。"

End Sub

Attribute VB_Name = "M93_一括インポート"
Sub 一括インポート()

    ' Microsoft Scripting Runtimeの参照設定に自動でチェック
    Const setRefFile As String = "C:\Windows\SysWOW64\scrrun.dll"
    ActiveWorkbook.VBProject.References.AddFromFile setRefFile

    Dim folderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
      .Show
      folderPath = .SelectedItems(1) & "\"
    End With

    Call ImportAll(ActiveWorkbook, folderPath)

End Sub

'// 指定ワークブックに指定フォルダ配下のモジュールをインポートする
'// 引数１：ワークブック
'// 引数２：モジュール格納フォルダパス
Sub ImportAll(a_TargetBook As Workbook, a_sModulePath As String)
    On Error Resume Next
    
    Dim oFso        As New FileSystemObject     '// FileSystemObjectオブジェクト
    Dim sArModule() As String                   '// モジュールファイル配列
    Dim sModule                                 '// モジュールファイル
    Dim sExt        As String                   '// 拡張子
    Dim iMsg                                    '// MsgBox関数戻り値
    
    iMsg = MsgBox("同名のモジュールは上書きします。よろしいですか？", vbOKCancel, "上書き確認")
    If (iMsg <> vbOK) Then
        Exit Sub
    End If
    
    ReDim sArModule(0)
    
    '// 全モジュールのファイルパスを取得
    Call searchAllFile(a_sModulePath, sArModule)
    
    '// 全モジュールをループ
    For Each sModule In sArModule
        '// 拡張子を小文字で取得
        sExt = LCase(oFso.GetExtensionName(sModule))
        
        '// 拡張子がcls、frm、basのいずれかの場合
        If (sExt = "cls" Or sExt = "frm" Or sExt = "bas") Then
            '// 同名モジュールを削除
            Call a_TargetBook.VBProject.VBComponents.Remove(a_TargetBook.VBProject.VBComponents(oFso.GetBaseName(sModule)))
            '// モジュールを追加
            Call a_TargetBook.VBProject.VBComponents.Import(sModule)
            '// Import確認用ログ出力
            Debug.Print sModule
        End If
    Next
End Sub
 
'// 指定フォルダ配下のファイルパスを取得
'// 引数１：フォルダパス
'// 引数２：ファイルパス配列
Sub searchAllFile(a_sFolder As String, s_ArFile() As String)
    Dim oFso        As New FileSystemObject
    Dim oFolder     As Folder
    Dim oSubFolder  As Folder
    Dim oFile       As File
    Dim i
    
    '// フォルダがない場合
    If (oFso.FolderExists(a_sFolder) = False) Then
        Exit Sub
    End If
    
    Set oFolder = oFso.GetFolder(a_sFolder)
    
    '// サブフォルダを再帰（サブフォルダを探す必要がない場合はこのFor文を削除してください）
    For Each oSubFolder In oFolder.SubFolders
        Call searchAllFile(oSubFolder.Path, s_ArFile)
    Next
    
    i = UBound(s_ArFile)
    
    '// カレントフォルダ内のファイルを取得
    For Each oFile In oFolder.Files
        If (i <> 0 Or s_ArFile(i) <> "") Then
            i = i + 1
            ReDim Preserve s_ArFile(i)
        End If
        
        '// ファイルパスを配列に格納
        s_ArFile(i) = oFile.Path
    Next
End Sub
Attribute VB_Name = "M94_ユーザーフォーム抽出"
Option Explicit

'UserFormと配置コントロールの全プロパティ値を取得する
Sub ユーザーフォーム抽出()
    Dim i As Long, ii As Long
    Dim a As Long
    Dim n As Long: n = 0
    Dim r As Long
    Dim ufrm As Object
    Dim c As control, inCtrl As control
    Dim s As Long
    Dim fname As String
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim tempSheet As String
    tempSheet = "UserFormテンプレ"
    Set wb = ActiveWorkbook
    
    Application.ScreenUpdating = False
    
    Dim ctrlArry() As String 'Variant
    With wb.VBProject
        For i = 1 To .VBComponents.Count
            If .VBComponents(i).Type = 3 Then 'Type = 3 ユーザーフォーム
    
                n = n + 1
                ReDim ctrlArry(39)
                fname = .VBComponents.Item(i).Name
                ctrlArry(0) = fname
                Set ufrm = UserForms.Add(fname)
                On Error Resume Next
                
                fnc_DeleteSheet (fname) '先にシート削除
                
                Worksheets(tempSheet).Copy After:=Worksheets(Worksheets.Count) 'シートコピペ
                ActiveSheet.Name = fname 'シート名変更
                Set ws = ThisWorkbook.Sheets(fname)
                
                With ufrm
                    For a = 1 To 39
                        ctrlArry(a) = getPVal(ws.Cells(a + 1, 1), ufrm)
                    Next a
                End With
                For ii = 0 To UBound(ctrlArry)
                    ws.Cells(ii + 1, 2) = ctrlArry(ii)
                Next ii
                On Error GoTo 0
                'ここからコントロールのプロパティ取得
                Dim con As Long: con = 0
                On Error Resume Next
                For Each c In ufrm.Controls
                    ReDim ctrlArry(123)    '要素数を初期化
                    con = con + 1
                    ctrlArry(0) = TypeName(c)
                    With c
                        For a = 1 To 122
                            ctrlArry(a) = getPVal(ws.Cells(a + 1, 3), c)
                        Next a
                        If ctrlArry(0) = "Frame" Or ctrlArry(0) = "MultiPage" Then
                            s = 0   '個数カウンター初期化
                            For Each inCtrl In c.Controls  '対象フレーム内のコントロール分ループ
                                s = s + 1
                            Next
                            ctrlArry(123) = s   'コントロール数を書き込む
                        End If
                    End With
                    For ii = 0 To UBound(ctrlArry)
                        ws.Cells(ii + 1, con + 3) = ctrlArry(ii)
                    Next ii
                Next
                On Error GoTo 0
                Set ufrm = Nothing
            End If
        Next i
        If n = 0 Then MsgBox "UserFormはありません！"
    End With
    Set ws = Nothing
    Set wb = Nothing
End Sub

'指定コントロールの値を取得する
Private Function getPVal(ByVal pName As String, obj As Object) As Variant
    Select Case pName
        Case "Accelerator": getPVal = obj.Accelerator
        Case "Alignment": getPVal = obj.Alignment
        Case "AllowColumnReorder": getPVal = obj.AllowColumnReorder
        Case "Appearance": getPVal = obj.Appearance
        Case "Arrenge": getPVal = obj.Arrenge
        Case "AutoSize": getPVal = obj.AutoSize
        Case "AutoTab": getPVal = obj.AutoTab
        Case "AutoWordSelect": getPVal = obj.AutoWordSelect
        Case "BackColor": getPVal = obj.BackColor
        Case "BackStyle": getPVal = obj.BackStyle
        Case "BorderColor": getPVal = obj.BorderColor
        Case "BorderStyle": getPVal = obj.BorderStyle
        Case "BoundColumn": getPVal = obj.BoundColumn
        Case "Cancel": getPVal = obj.Cancel
        Case "Caption": getPVal = "'" & obj.Caption
        Case "Checkboxes": getPVal = obj.CheckBoxes
        Case "ColumnCount": getPVal = obj.ColumnCount
        Case "ColumnHeads": getPVal = obj.ColumnHeads
        Case "ColumnWidths": getPVal = obj.ColumnWidths
        Case "ControlSource": getPVal = obj.ControlSource
        Case "ControlTipText": getPVal = obj.ControlTipText
        Case "Cycle": getPVal = obj.Cycle
        Case "Default": getPVal = obj.Default
        Case "Delay": getPVal = obj.Delay
        Case "DragBehavior": getPVal = obj.DragBehavior
        Case "DrawBuffer": getPVal = obj.DrawBuffer
        Case "DropButtonStyle": getPVal = obj.DropButtonStyle
        Case "Enabled": getPVal = obj.Enabled
        Case "EnterFieldBehavior": getPVal = obj.EnterFieldBehavior
        Case "EnterKeyBehavior": getPVal = obj.EnterKeyBehavior
        Case "FlatScrollBar": getPVal = obj.FlatScrollBar
        Case "Font": getPVal = obj.Font.Name
        Case "FontSize": getPVal = obj.Font.Size
        Case "FontBold": getPVal = obj.Font.Bold
        Case "FontItalic": getPVal = obj.Font.Italic
        Case "FontStrikethrough": getPVal = obj.Font.Strikethrough
        Case "FontUnderline": getPVal = obj.Font.Underline
        Case "ForeColor": getPVal = obj.ForeColor
        Case "FullRowSlect": getPVal = obj.FullRowSlect
        Case "GridLines": getPVal = obj.Gridlines
        Case "GroupName": getPVal = obj.GroupName
        Case "Height": getPVal = obj.Height
        Case "HelpConTextID": getPVal = obj.HelpContextID
        Case "HideColumnHeaders": getPVal = obj.HideColumnHeaders
        Case "HideSelection": getPVal = obj.HideSelection
        Case "HotTracking": getPVal = obj.HotTracking
        Case "HoverSelection": getPVal = obj.HoverSelection
        Case "IMEMode": getPVal = obj.IMEMode
        Case "IntegralHeight": getPVal = obj.IntegralHeight
        Case "KeepScrollbarsVisible": getPVal = obj.KeepScrollBarsVisible
        Case "LabelEdit": getPVal = obj.LabelEdit
        Case "LabelWrap": getPVal = obj.LabelWrap
        Case "LargeChange": getPVal = obj.LargeChange
        Case "Left": getPVal = obj.Left
        Case "ListRows": getPVal = obj.ListRows
        Case "ListStyle": getPVal = obj.ListStyle
        Case "ListWidth": getPVal = obj.ListWidth
        Case "Locked": getPVal = obj.Locked
        Case "MatchEntry": getPVal = obj.MatchEntry
        Case "MatchRequired": getPVal = obj.MatchRequired
        Case "Max": getPVal = obj.Max
        Case "MaxLength": getPVal = obj.MaxLength
        Case "Min": getPVal = obj.Min
        Case "MouseIcon": getPVal = obj.MouseIcon
        Case "MousePointer": getPVal = obj.MousePointer
        Case "MultiLine": getPVal = obj.MultiLine
        Case "MultiRow": getPVal = obj.MultiRow
        Case "MultiSelect": getPVal = obj.MultiSelect
        Case "OLEDragMode": getPVal = obj.OLEDragMode
        Case "OLEDropMode": getPVal = obj.OLEDropMode
        Case "Orientation": getPVal = obj.Orientation
        Case "PasswordChar": getPVal = obj.PasswordChar
        Case "Picture": getPVal = obj.Picture
        Case "pictureAlignment": getPVal = obj.PictureAlignment
        Case "PicturePosition": getPVal = obj.PicturePosition
        Case "PictureSizeMode": getPVal = obj.PictureSizeMode
        Case "PictureTiling": getPVal = obj.PictureTiling
        Case "ProportionalThumb": getPVal = obj.ProportionalThumb
        Case "RightToLeft": getPVal = obj.RightToLeft
        Case "RowSource": getPVal = obj.RowSource
        Case "ScrollBars": getPVal = obj.ScrollBars
        Case "ScrollHeight": getPVal = obj.ScrollHeight
        Case "Scrolling": getPVal = obj.Scrolling
        Case "ScrollLeft": getPVal = obj.ScrollLeft
        Case "ScrollTop": getPVal = obj.ScrollTop
        Case "ScrollWidth": getPVal = obj.ScrollWidth
        Case "SelectionMargin": getPVal = obj.SelectionMargin
        Case "SelLength": getPVal = obj.SelLength
        Case "SelStart": getPVal = obj.SelStart
        Case "SelText": getPVal = obj.SelText
        Case "ShowDropButtonWhen": getPVal = obj.ShowDropButtonWhen
        Case "ShowModal": getPVal = obj.ShowModal
        Case "SmallChange": getPVal = obj.SmallChange
        Case "Sorted": getPVal = obj.Sorted
        Case "SortKey": getPVal = obj.SortKey
        Case "SortOder": getPVal = obj.SortOder
        Case "SpecialEffect": getPVal = obj.SpecialEffect
        Case "StartUpPosition": getPVal = obj.StartUpPosition
        Case "Style": getPVal = obj.Style
        Case "TabFixedHeight": getPVal = obj.TabFixedHeight
        Case "TabFixedWidth": getPVal = obj.TabFixedWidth
        Case "TabIndex": getPVal = obj.TabIndex
        Case "TabKeyBehavior": getPVal = obj.TabKeyBehavior
        Case "TabOrientationTop": getPVal = obj.TabOrientationTop
        Case "TabStop": getPVal = obj.TabStop
        Case "Tag": getPVal = obj.Tag
        Case "TakeFocusOnClick": getPVal = obj.TakeFocusOnClick
        Case "Text": getPVal = obj.Text
        Case "TextAlign": getPVal = obj.TextAlign
        Case "TextBackground": getPVal = obj.TextBackground
        Case "TextColumn": getPVal = obj.TextColumn
        Case "Top": getPVal = obj.top
        Case "TopIndex": getPVal = obj.TopIndex
        Case "TriPleState": getPVal = obj.TripleState
        Case "Value": getPVal = obj.Value
        Case "View": getPVal = obj.View
        Case "Visible": getPVal = obj.Visible
        Case "WhatThisButton": getPVal = obj.WhatThisButton
        Case "WhatThisHelp": getPVal = obj.WhatThisHelp
        Case "Width": getPVal = obj.Width
        Case "WordWrap": getPVal = obj.WordWrap
        Case "Zoom": getPVal = obj.Zoom
    End Select
End Function


Attribute VB_Name = "M95_ユーザーフォーム作成"
Option Explicit

'取得データからユーザーフォームを作成する
Sub ユーザーフォーム作成()
    Dim Frm As VBIDE.VBComponent
    Dim Ctrl As MSForms.control
    
    Dim wb As Workbook
    Dim sh As Worksheet
    Dim arr As Variant  '配列用変数
    Dim r As Long, i As Long
    Dim x As Long, y As Long
    
    Set wb = ActiveWorkbook
    'Set sh = wb.Worksheets("UserFormテンプレ")     '設定値保存シート
    Set sh = ActiveSheet
    r = sh.Cells(Rows.Count, 1).End(xlUp).Row   'UserForm設定値の最終行取得
    ReDim arr(1 To r, 1 To 2)   '２次元配列初期化セット
    'シートに保存した設定値を取得する
    For y = 1 To r          '行数分のループ
        For x = 1 To 2      '列数分のループ
            arr(y, x) = sh.Cells(y, x)  'セルからプロパティ設定を取得
        Next x
    Next y
   'ユーザフォームを追加
    Set Frm = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
    On Error Resume Next    '設定できない場合エラーでストップしないように
    With Frm
        For i = 2 To r
            .Properties(arr(i, 1)) = arr(i, 2)  'UserFormのプロパティ値セット
        Next i
        'ここからは各コントロールを設置する処理
        Dim c As Long, j As Long
        Dim chk As Long, n As Long
        Dim ctrlName As String, cName As String
        'コントロールのデータ最終列取得
        c = sh.Cells(1, Columns.Count).End(xlToLeft).Column
        'プロパティー数取得（３列目から）
        r = sh.Cells(Rows.Count, 3).End(xlUp).Row
        ReDim arr(1 To r, 1 To 2)   '配列初期化
        For j = 4 To c  '3列目がプロパティ名なので4列目からが設定値
            'シートに保存した設定値を取得する
            For y = 1 To r
                arr(y, 1) = sh.Cells(y, 3)  'プロパティ名
                arr(y, 2) = sh.Cells(y, j)  'プロパティ値
            Next y
            ctrlName = arr(1, 2)            'コントロール名
            cName = "Forms." & ctrlName & ".1"
            'コントロール設置
            Set Ctrl = .Designer.Controls.Add(cName)
            With Ctrl
                For i = 2 To r
                    'コントロールのプロパティ値設定処理へ
                    Call setPVal(arr(i, 1), Ctrl, arr(i, 2))
                    '子コントロールがあるかどうかチェック
                    If i = r Then chk = arr(i, 2)   'chk = 子コントロール数
                Next i
                'フレーム又はマルチページの場合内部のコントロール配置へ
                If ctrlName = "Frame" Or ctrlName = "MultiPage" Then
                    For n = 1 To chk  '内部に配置するコントロール数分ループ
                        ReDim arr(1 To r, 1 To 2)   '配列初期化
                        j = j + 1   '次の列指定へカウンター増加
                        'シートに保存した設定値を取得する
                        For y = 1 To r
                            arr(y, 1) = sh.Cells(y, 3)  'プロパティ名
                            arr(y, 2) = sh.Cells(y, j)  'プロパティ値
                        Next y
                        ctrlName = arr(1, 2)
                        cName = "Forms." & ctrlName & ".1"
                        '内部にコントロールを設置する
                        Set Ctrl = .Controls.Add(cName) 'コントロール内に配置
                        With Ctrl
                            For i = 2 To r
                                'コントロールのプロパティ値設定処理へ
                                Call setPVal(arr(i, 1), Ctrl, arr(i, 2))
                            Next i
                        End With
                    Next n
                End If
            End With
        Next j
    End With
    On Error GoTo 0
    Set Ctrl = Nothing
    Set Frm = Nothing
End Sub

'指定コントロールのプロパティ値をセットする
Private Function setPVal(ByVal pName As String, _
                            obj As Object, _
                            pVal As Variant) As Variant
    Select Case pName
        Case "Accelerator": obj.Accelerator = pVal
        Case "Alignment": obj.Alignment = pVal
        Case "AllowColumnReorder": obj.AllowColumnReorder = pVal
        Case "Appearance": obj.Appearance = pVal
        Case "Arrenge": obj.Arrenge = pVal
        Case "AutoSize": obj.AutoSize = pVal
        Case "AutoTab": obj.AutoTab = pVal
        Case "AutoWordSelect": obj.AutoWordSelect = pVal
        Case "BackColor": obj.BackColor = pVal
        Case "BackStyle": obj.BackStyle = pVal
        Case "BorderColor": obj.BorderColor = pVal
        Case "BorderStyle": obj.BorderStyle = pVal
        Case "BoundColumn": obj.BoundColumn = pVal
        Case "Cancel": obj.Cancel = pVal
        Case "Caption": obj.Caption = pVal
        Case "Checkboxes": obj.CheckBoxes = pVal
        Case "ColumnCount": obj.ColumnCount = pVal
        Case "ColumnHeads": obj.ColumnHeads = pVal
        Case "ColumnWidths": obj.ColumnWidths = pVal
        Case "ControlSource": obj.ControlSource = pVal
        Case "ControlTipText": obj.ControlTipText = pVal
        Case "Cycle": obj.Cycle = pVal
        Case "Default": obj.Default = pVal
        Case "Delay": obj.Delay = pVal
        Case "DragBehavior": obj.DragBehavior = pVal
        Case "DrawBuffer": obj.DrawBuffer = pVal
        Case "DropButtonStyle": obj.DropButtonStyle = pVal
        Case "Enabled": obj.Enabled = pVal
        Case "EnterFieldBehavior": obj.EnterFieldBehavior = pVal
        Case "EnterKeyBehavior": obj.EnterKeyBehavior = pVal
        Case "FlatScrollBar": obj.FlatScrollBar = pVal
        Case "Font": obj.Font.Name = pVal
        Case "FontSize": obj.Font.Size = pVal
        Case "FontBold": obj.Font.Bold = pVal
        Case "FontItalic": obj.Font.Italic = pVal
        Case "FontStrikethrough": obj.Font.Strikethrough = pVal
        Case "FontUnderline": obj.Font.Underline = pVal
        Case "ForeColor": obj.ForeColor = pVal
        Case "FullRowSlect": obj.FullRowSlect = pVal
        Case "GridLines": obj.Gridlines = pVal
        Case "GroupName": obj.GroupName = pVal
        Case "Height": obj.Height = pVal
        Case "HelpConTextID": obj.HelpContextID = pVal
        Case "HideColumnHeaders": obj.HideColumnHeaders = pVal
        Case "HideSelection": obj.HideSelection = pVal
        Case "HotTracking": obj.HotTracking = pVal
        Case "HoverSelection": obj.HoverSelection = pVal
        Case "IMEMode": obj.IMEMode = pVal
        Case "IntegralHeight": obj.IntegralHeight = pVal
        Case "KeepScrollbarsVisible": obj.KeepScrollBarsVisible = pVal
        Case "LabelEdit": obj.LabelEdit = pVal
        Case "LabelWrap": obj.LabelWrap = pVal
        Case "LargeChange": obj.LargeChange = pVal
        Case "Left": obj.Left = pVal
        Case "ListRows": obj.ListRows = pVal
        Case "ListStyle": obj.ListStyle = pVal
        Case "ListWidth": obj.ListWidth = pVal
        Case "Locked": obj.Locked = pVal
        Case "MatchEntry": obj.MatchEntry = pVal
        Case "MatchRequired": obj.MatchRequired = pVal
        Case "Max": obj.Max = pVal
        Case "MaxLength": obj.MaxLength = pVal
        Case "Min": obj.Min = pVal
        Case "MouseIcon": obj.MouseIcon = pVal
        Case "MousePointer": obj.MousePointer = pVal
        Case "MultiLine": obj.MultiLine = pVal
        Case "MultiRow": obj.MultiRow = pVal
        Case "MultiSelect": obj.MultiSelect = pVal
        Case "OLEDragMode": obj.OLEDragMode = pVal
        Case "OLEDropMode": obj.OLEDropMode = pVal
        Case "Orientation": obj.Orientation = pVal
        Case "PasswordChar": obj.PasswordChar = pVal
        Case "Picture": obj.Picture = pVal
        Case "pictureAlignment": obj.PictureAlignment = pVal
        Case "PicturePosition": obj.PicturePosition = pVal
        Case "PictureSizeMode": obj.PictureSizeMode = pVal
        Case "PictureTiling": obj.PictureTiling = pVal
        Case "ProportionalThumb": obj.ProportionalThumb = pVal
        Case "RightToLeft": obj.RightToLeft = pVal
        Case "RowSource": obj.RowSource = pVal
        Case "ScrollBars": obj.ScrollBars = pVal
        Case "ScrollHeight": obj.ScrollHeight = pVal
        Case "Scrolling": obj.Scrolling = pVal
        Case "ScrollLeft": obj.ScrollLeft = pVal
        Case "ScrollTop": obj.ScrollTop = pVal
        Case "ScrollWidth": obj.ScrollWidth = pVal
        Case "SelectionMargin": obj.SelectionMargin = pVal
        Case "SelLength": obj.SelLength = pVal
        Case "SelStart": obj.SelStart = pVal
        Case "SelText": obj.SelText = pVal
        Case "ShowDropButtonWhen": obj.ShowDropButtonWhen = pVal
        Case "ShowModal": obj.ShowModal = pVal
        Case "SmallChange": obj.SmallChange = pVal
        Case "Sorted": obj.Sorted = pVal
        Case "SortKey": obj.SortKey = pVal
        Case "SortOder": obj.SortOder = pVal
        Case "SpecialEffect": obj.SpecialEffect = pVal
        Case "StartUpPosition": obj.StartUpPosition = pVal
        Case "Style": obj.Style = pVal
        Case "TabFixedHeight": obj.TabFixedHeight = pVal
        Case "TabFixedWidth": obj.TabFixedWidth = pVal
        Case "TabIndex": obj.TabIndex = pVal
        Case "TabKeyBehavior": obj.TabKeyBehavior = pVal
        Case "TabOrientationTop": obj.TabOrientationTop = pVal
        Case "TabStop": obj.TabStop = pVal
        Case "Tag": obj.Tag = pVal
        Case "TakeFocusOnClick": obj.TakeFocusOnClick = pVal
        Case "Text": obj.Text = pVal
        Case "TextAlign": obj.TextAlign = pVal
        Case "TextBackground": obj.TextBackground = pVal
        Case "TextColumn": obj.TextColumn = pVal
        Case "Top": obj.top = pVal
        Case "TopIndex": obj.TopIndex = pVal
        Case "TriPleState": obj.TripleState = pVal
        Case "Value": obj.Value = pVal
        Case "View": obj.View = pVal
        Case "Visible": obj.Visible = pVal
        Case "WhatThisButton": obj.WhatThisButton = pVal
        Case "WhatThisHelp": obj.WhatThisHelp = pVal
        Case "Width": obj.Width = pVal
        Case "WordWrap": obj.WordWrap = pVal
        Case "Zoom": obj.Zoom = pVal
    End Select
End Function





Attribute VB_Name = "M96_Moduleインポート"
Sub Moduleインポート()

  ' Microsoft Scripting Runtimeの参照設定に自動でチェック
  'Const setRefFile As String = "C:\Windows\SysWOW64\scrrun.dll"
  'ActiveWorkbook.VBProject.References.AddFromFile setRefFile

  Dim wsh As Object
  Set wsh = CreateObject("WScript.Shell")
  
  Dim fPath As Variant

'  fPath = Application.GetOpenFilename(FileFilter:="Module, *.cls;*.frm;*.bas")
'  If fPath <> False Then
'       MsgBox fPath
'  End If
  
  
  'With Application.FileDialog(msoFileDialogFolderPicker)
  With Application.FileDialog(msoFileDialogFilePicker)
    '初期表示フォルダの設定
    .InitialFileName = wsh.SpecialFolders("Desktop") & "\"
    'ファイルフィルタのクリア
    .Filters.Clear
    'ファイルフィルタの追加
    .Filters.Add "Module", "*.cls;*.frm;*.bas"
    
    
    If .Show = -1 Then  'ファイルダイアログ表示
          strFiles = .SelectedItems(1)
    Else
      ' [ キャンセル ] ボタンが押された場合
      Exit Sub
    End If
    
  End With


  
  Dim fso        As New FileSystemObject     '// FileSystemObjectオブジェクト
'  Dim sArModule() As String                   '// モジュールファイル配列
'  Dim sModule                                 '// モジュールファイル
  Dim sExt        As String                   '// 拡張子
'  Dim iMsg                                    '// MsgBox関数戻り値
  
  '拡張子を小文字で取得
  sExt = LCase(fso.GetExtensionName(strFiles))
  
  
 
        
  '// 拡張子がcls、frm、basのいずれかの場合
  If (sExt = "cls" Or sExt = "frm" Or sExt = "bas") Then
  
    For i = 1 To ActiveWorkbook.VBProject.VBComponents.Count
      If ActiveWorkbook.VBProject.VBComponents(i).Name = fso.GetBaseName(strFiles) Then
        '// 同名モジュールが存在すれば削除
        Call ActiveWorkbook.VBProject.VBComponents.Remove(ActiveWorkbook.VBProject.VBComponents(fso.GetBaseName(strFiles)))
        Exit For
      End If
    Next
   
    '// モジュールを追加
    Call ActiveWorkbook.VBProject.VBComponents.Import(strFiles)
    MsgBox "以下のモジュールをインポートしました。" & vbCrLf & vbCrLf & fso.GetBaseName(strFiles)
  End If
        
        
  '後片付け
  Set wsh = Nothing
        
End Sub
Attribute VB_Name = "M97_シート復元"
Sub シート復元()

  Call fnc_st
  
  Sheets(1).Activate
  
  Range(Cells(1, 1), Cells(2, 7)).Interior.Color = RGB(241, 169, 131) 'セル色塗り
  Range(Cells(1, 2), Cells(1, 6)).Merge True
  Cells(1, 2).HorizontalAlignment = xlCenter
    
  Dummy = ActiveSheet.UsedRange.Row '終端セル誤認バグ修正
  Dummy = ActiveSheet.UsedRange.Column '終端セル誤認バグ修正
  r = Range("A1").SpecialCells(xlLastCell).Row '一番下の行
  c = Range("A1").SpecialCells(xlLastCell).Column '一番右の列
  
  Range(Cells(1, 1), Cells(r, c)).Borders.LineStyle = xlContinuous 'セル罫線
  Range(Cells(1, 1), Cells(r, c)).Columns.AutoFit 'セル列幅調整

  
  '書式設定
  Dim myCond As FormatCondition
  
  With Range(Cells(3, 1), Cells(r, c))
    .FormatConditions.Delete 'セルの書式設定削除
    Set myCond = .FormatConditions.Add(Type:=xlExpression, Operator:=xlEqual, Formula1:="=$B3=1")
    myCond.Font.Color = -16752384
    myCond.Interior.Color = 13561798
    
    Set myCond = .FormatConditions.Add(Type:=xlExpression, Operator:=xlEqual, Formula1:="=$B3=0")
    myCond.Font.Color = -16383844
    myCond.Interior.Color = 13551615
    
    .FormatConditions(1).StopIfTrue = False
  End With
  
  Call fnc_end

End Sub