Sub SpinLock()
'=============================================
'概要：スピンボタンの参照をOffset(0, 1)に強制します①
'引数：なし
'戻り値：なし
'=============================================
With ActiveSheet.Shapes(Application.Caller)
.TopLeftCell.Offset(0, 1) = .OLEFormat.Object.Value
End With
End Sub
Sub RecordAdd()
'=============================================
'概要：タスク及びレコードを追加します
'引数：なし
'戻り値: なし
'=============================================
Range("A1").Value = "ロック"
Dim i As Integer 'レコードの最終行を特定する変数
Dim str As String 'タスク名
'タスク名の入力
str = InputBox("TASK名を入力してください。", "TASK名")
If str = "" Or str = "[100%samp]" Or str = "[0%samp]" Then
Exit Sub
End If
'変数の初期化
i = 4
'最終行取得
Do
i = i + 1
Loop While Cells(i, 3).Value <> ""
'レコード追加
Cells(i - 1, 3).Select
Selection.ListObject.ListRows.Add AlwaysInsert:=True
'スピンボタンのコピー
Cells(i - 1, 2).Copy Cells(i, 2)
'その他レコードのカラム毎初期値設定
Cells(i, 3).Value = 0
Cells(i, 2).Value = str
'レコードの並び替え
ActiveWorkbook.Worksheets("Sheet1").ListObjects("テーブル1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("テーブル1").Sort.SortFields.Add _
Key:=Range("テーブル1[進捗]"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Value = ""
End Sub
Sub MakeTaskFile()
'=============================================
'概要：選択したタスクの作業フォルダを作成します。
'引数：なし
'戻り値: なし
'=============================================
Dim rng As Range '選択範囲を取得する変数
Dim taskName As String '選択したタスクの名前
Dim mkFileName As String '作るファイルの名前
Dim mkNum As Integer '作るファイルの連番
Dim runFile As String '走査するファイル名を格納する変数
Dim runNum As Integer '走査する連番を格納する変数
Dim runTask As String '走査するタスク名を格納する変数
Dim numExist As Boolean '連番がすでに存在するかどうかを表す
Range("A1").Value = "ロック"
'選択範囲からタスク名を取得する
Set rng = Range(Selection.Address)
taskName = Cells(rng.Row, 2).Value
'エラーチェック：選択したタスクが適しているか判定
If taskName = "" Or taskName = "[0%samp]" Or taskName = "[100%samp]" Or taskName = "TASK名" Then
MsgBox "ファイルを作成したいTASKを選択してください。", vbCritical
Range("A1").Value = ""
Exit Sub
End If
'フォルダを走査する前の初期値設定
mkFileName = "TASK_01_" & taskName & "_" & Format(Date, "mmdd")
mkNum = 1
numExist = False
'フォルダ走査
1:
runFile = Dir(ThisWorkbook.Path & "\TASK*", vbDirectory)
Do While runFile <> ""
runNum = Val(Left(Mid(runFile, 6), 2))
runTask = Left(Mid(runFile, 9), InStr(Mid(runFile, 9), "_") - 1)
'既にタスクファイルが作られてないかチェック
If runTask = taskName Then
MsgBox "そのタスク名のファイルは既に存在しています。", vbCritical
Range("A1").Value = ""
Exit Sub
End If
'連番が既に存在していないかチェック
If runNum = mkNum Then
numExist = True
End If
runFile = Dir()
Loop
'連番が既に存在していれば連番の数を一つ上げて再走査
If numExist = True Then
mkNum = mkNum + 1
mkFileName = "TASK_" & Format(mkNum, "00") & "_" & taskName & "_" & Format(Date, "mmdd")
numExist = False
GoTo 1
End If
'条件を満たしていればフォルダ作成
MkDir (ThisWorkbook.Path & "\" & mkFileName)
'その配下に作業メモを置く
Open ThisWorkbook.Path & "\" & mkFileName & "\作業メモ" For Output As #1
Print #1, taskName & "の作業メモ"
Close #1
MsgBox taskName & "のタスクフォルダを作成しました。"
Range("A1").Value = ""
End Sub
以下シートに
Private Sub Worksheet_Change(ByVal Target As Range)
'=============================================
'概要：スピンボタンの参照をOffset(0, 1)に強制します②
'また進捗が100を記録した場合降順に並べます。
'引数：target as range
'戻り値: なし
'=============================================
Dim shp As Object
For Each shp In ActiveSheet.Shapes
If shp.Name Like "*Spinner*" And Target.Address = Cells(shp.TopLeftCell.Row, shp.TopLeftCell.Column + 1).Address Then
shp.OLEFormat.Object.Value = Target.Value
End If
Next
'進捗が100を記録した場合降順に並べます。
If Range("A1").Value <> "ロック" Then
If Target.Column = 3 And Target.Value = 100 Then
taskName = Cells(Target.Row, Target.Column - 1).Value
ActiveWorkbook.Worksheets("Sheet1").ListObjects("テーブル1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").ListObjects("テーブル1").Sort.SortFields.Add _
Key:=Range("テーブル1[進捗]"), SortOn:=xlSortOnValues, Order:=xlDescending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").ListObjects("テーブル1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End If
End If
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'=============================================
'概要：レコードを削除します。
'引数：target as range,Cancel As Boolean
'戻り値: なし
'=============================================
Dim ans As String
If Target.Column > 1 And Target.Column < 9 And Target.Row > 4 And Cells(Target.Row, 3).Value <> "" And Cells(Target.Row, 2).Value <> "[0%samp]" And Cells(Target.Row, 2).Value <> "[100%samp]" Then
ans = MsgBox("TASKを削除しますか？", vbYesNo, "削除確認")
If ans = vbYes Then
Range("A1").Value = "ロック"
Selection.ListObject.ListRows(Range(Selection.Address).Row - 4).Delete
Range("A1").Value = ""
End If
End If
Cancel = True
End Sub