ExcelVBAで作成したタスク管理シートのVBAプログラムソース(スクリプト)公開xcelVBAで作成したタスク管理シートのVBAプログラムソース(スクリプト)を公開します。タスク管理シートのダウンロードもできます。■ Excelシート名:"Task.xls" Excelタスク管理シートダウンロード ■ Excelタスク管理シート並び替え用VBAプログラム Sub 並び替えスペシャル() ' ' 並び替えスペシャル Macro ' マクロ記録日 : 2006/4/12 ユーザー名 : Ogawa ' ' Dim a, b, c, i, x, y As Integer '●●2行目の罫線を通常にする Range("A2:F2").Select Range("F2").Activate Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With ' With Selection.Borders(xlInsideHorizontal) ' .LineStyle = xlContinuous ' .Weight = xlThin ' .ColorIndex = xlAutomatic ' End With '●●記述が無ければ2行目を削除 If Cells(2, 4) = " Then Rows("2:2").Select Selection.Delete Shift:=xlUp End If '●●並び替え Range("A1").Select Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _ :=xlPinYin For y = 2 To 100 If Cells(y, 1) = "1" Then For x = 1 To 6 Cells(y, x).Select Selection.Font.ColorIndex = 3 '●●"1"の場合赤を指定 Next x If Cells(y, 5) = " Then Cells(y, 5) = Date '●●開始日が空欄の場合には日付を埋め込む End If Else If Cells(y, 1) = "2" Then For x = 1 To 6 Cells(y, x).Select Selection.Font.ColorIndex = 5 '●●"2"の場合青を指定 Next x If Cells(y, 5) = " Then Cells(y, 5) = Date '●●開始日が空欄の場合には日付を埋め込む End If Else If Cells(y, 1) = "3" Then For x = 1 To 6 Cells(y, x).Select Selection.Font.ColorIndex = 1 '●●"3"の場合黒を指定 Next x If Cells(y, 5) = " Then Cells(y, 5) = Date '●●開始日が空欄の場合には日付を埋め込む End If Else For x = 1 To 6 Cells(y, x).Select Selection.Font.ColorIndex = 15 '●●その他の場合グレーを指定 Next x If Cells(y, 6) = " And Cells(y, 1) <> " Then Cells(y, 6) = Date '●●完了日が空欄の場合には日付を埋め込む End If End If End If End If Next y '●●2行目に1行挿入 Rows("2:2").Select Selection.Insert Shift:=xlDown '●●2行目の書式設定 Range("A3:F3").Select Range("F3").Activate Selection.Copy Range("A2").Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Range("A2:F2").Select Range("F2").Activate Selection.Font.ColorIndex = 1 '●●挿入した行の罫線を太くする Range("A2:D2").Select Range("D2").Activate Selection.Borders(xlDiagonalDown).LineStyle = xlNone Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .Weight = xlMedium .ColorIndex = xlAutomatic End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .Weight = xlThin .ColorIndex = xlAutomatic End With Range("A2").Select '●●挿入した行のフォントの太字をオフ Rows("2:2").Select Selection.Font.Bold = False Range("A2").Select '●●挿入した行の高さを補正 Rows("2:2").EntireRow.AutoFit End Sub
|
