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