エクセル小僧:更新期限切れのセルを選択(改2) [コンピューター]
定期的に更新が必要なモノの一覧があって、ファイルを開いたときに
期限切れのセルを選択し、期限切れのセルのうち、最古のセルがアクティブに
なっているようにするマクロを作ってみました。
http://cheese999.blog.so-net.ne.jp/2016-04-24
で紹介したマクロを変更し、最古のセルがアクティブになるように変更しました。
【条件】
・G列に変更した日が入力されている。
・変更日のセル範囲に"変更日"という名前がついている。
・更新は90日ごとに行う。
【マクロ】
☆呼び出し側
Private Sub Workbook_Open()
' Workbookを開いたときの処理
' 現在の時刻、更新日を表示
' 配列を定義
Dim str1(2) As String
Dim mySheet(1) As Worksheet
Dim myRange1 As Range
' 現在の時刻の文字列を生成
str1(0) = Format(Now(), "yyyy/mm/dd(aaa) hh:mm:ss")
' "現在:"と改行を連結
' Tab[Chr(9)]で:の位置を揃える
str1(1) = "現在" & Chr(9) & ":" & str1(0) & vbCrLf
' 更新日(J1セル)を連結
Set mySheet(0) = ActiveSheet ' アクティブシートを退避
Set mySheet(1) = Worksheets("current") ' 更新日のあるシート
mySheet(1).Activate ' currentシートをアクティブ化
str1(1) = str1(1) & "更新日" & Chr(9) & ":" & Format(Range("J1"), "yyyy/mm/dd(aaa) hh:mm:ss")
' メッセージボックスに現在の日時と更新日を表示
MsgBox str1(1)
Set myRange1 = Range("変更日") ' 変更日のセル範囲
Call HenKigen1(mySheet(1), -90, myRange1) '変更から90日経過した最初のセルへ飛ぶ
End Sub
☆呼び出される側
Sub HenKigen1(ByVal sheet1 As Worksheet, ByVal Nod1 As Long, ByVal myRange1 As Range)
'【機能】パスワード変更から-Nod1日経過した最初のセルへ飛ぶ
'【引数】
' sheet1 : シート名
' Nod1 : 日数 (Number of Days) 90日前の場合 Nod1=-90
' myRange1 : 検索対象のセル範囲
'【変数】
Dim Day1 As Date ' 基準日
Dim Day2 As Date ' 条件に合致したセルの中で最も古い日付
Dim Range1 As Range ' セル範囲
Dim Range2 As Range ' セル範囲(最も古い日付)
Dim Range_t As Range ' セル範囲(合計)
Dim NoC As Long ' 条件に合致したセル数(Number of Cell)
Dim Nod2 As Long ' Nod1の逆
'【コード】
sheet1.Activate ' 対象シートをアクティブ化
Day1 = Date ' 今日
Day1 = DateAdd("d", Nod1, Day1) ' -Nod1日前
For Each Range1 In myRange1
If (Range1.Value <> "") And (Range1.Value < Day1) Then ' 変更日が-Nod1日より前
If Range_t Is Nothing Then
Set Range_t = Range1 ' 最初に条件に合致したセル
Set Range2 = Range1 ' 最初に条件に合致したセル(最も古い日付)
Day2 = Range1.Value ' 最も古い日付を更新
NoC = 1 ' 合致したセル数をカウント
Else
Set Range_t = Union(Range_t, Range1) ' 2個目以降に条件に合致したセルを結合
NoC = NoC + 1 ' 合致したセル数をカウントアップ
If Range1.Value < Day2 Then
Set Range2 = Range1 ' 最も古い日付のセルを更新
Day2 = Range1.Value ' 最も古い日付を更新
End If
End If
End If
Next Range1
If Not (Range_t Is Nothing) Then ' 合致したセルがあったら
' Application.Goto Range2, True ' パスワード変更から-Nod1日経過したセルの内、最古のセルへ
Range_t.Select ' パスワード変更から-Nod1日経過したセル範囲を選択
Range2.Activate ' パスワード変更から-Nod1日経過したセルの内、最古のセルをActivate
ActiveWindow.SmallScroll ToLeft:=Range_t(1, 1).Column - 1 ' A列が一番左になるようにスクロール
Nod2 = 0 - Nod1 ' Nod1の符号を反転
MsgBox ("変更から" & Nod2 & "日以上経過したパスワードは" & NoC & "個あります。" & _
vbCrLf & "最古は" & Range2.Address & "(" & Day2 & ")です。") ' 合致したセル数の表示
End If
End Sub
【解説】
・For Each文で、myRange1 のセル範囲内のセルの値を調べていきます。
・セル範囲に"変更日"という名前を付けているのは、セル範囲が変更になってもマクロ変更しなくてもすむようにです。
・アクティブシートを退避して、"current"シートをアクティブ化していますが、マクロ実行前のアクティブシートに戻っていないので、退避する必要はない、ですね。。
・変更日のセルが空白の場合は対象としないよう、(Range1.Value <> "") ではじいています。
・Nod1はマイナスの値で与えられることに注意してください。
・条件に合致したセルをRange_tに格納しますが、1セル目と2セル目では格納の仕方が異なります。1セル目かどうか、つまり、Range_tが空っぽかどうかを、Nothingを使って判定しています。
期限切れのセルを選択し、期限切れのセルのうち、最古のセルがアクティブに
なっているようにするマクロを作ってみました。
http://cheese999.blog.so-net.ne.jp/2016-04-24
で紹介したマクロを変更し、最古のセルがアクティブになるように変更しました。
【条件】
・G列に変更した日が入力されている。
・変更日のセル範囲に"変更日"という名前がついている。
・更新は90日ごとに行う。
【マクロ】
☆呼び出し側
Private Sub Workbook_Open()
' Workbookを開いたときの処理
' 現在の時刻、更新日を表示
' 配列を定義
Dim str1(2) As String
Dim mySheet(1) As Worksheet
Dim myRange1 As Range
' 現在の時刻の文字列を生成
str1(0) = Format(Now(), "yyyy/mm/dd(aaa) hh:mm:ss")
' "現在:"と改行を連結
' Tab[Chr(9)]で:の位置を揃える
str1(1) = "現在" & Chr(9) & ":" & str1(0) & vbCrLf
' 更新日(J1セル)を連結
Set mySheet(0) = ActiveSheet ' アクティブシートを退避
Set mySheet(1) = Worksheets("current") ' 更新日のあるシート
mySheet(1).Activate ' currentシートをアクティブ化
str1(1) = str1(1) & "更新日" & Chr(9) & ":" & Format(Range("J1"), "yyyy/mm/dd(aaa) hh:mm:ss")
' メッセージボックスに現在の日時と更新日を表示
MsgBox str1(1)
Set myRange1 = Range("変更日") ' 変更日のセル範囲
Call HenKigen1(mySheet(1), -90, myRange1) '変更から90日経過した最初のセルへ飛ぶ
End Sub
☆呼び出される側
Sub HenKigen1(ByVal sheet1 As Worksheet, ByVal Nod1 As Long, ByVal myRange1 As Range)
'【機能】パスワード変更から-Nod1日経過した最初のセルへ飛ぶ
'【引数】
' sheet1 : シート名
' Nod1 : 日数 (Number of Days) 90日前の場合 Nod1=-90
' myRange1 : 検索対象のセル範囲
'【変数】
Dim Day1 As Date ' 基準日
Dim Day2 As Date ' 条件に合致したセルの中で最も古い日付
Dim Range1 As Range ' セル範囲
Dim Range2 As Range ' セル範囲(最も古い日付)
Dim Range_t As Range ' セル範囲(合計)
Dim NoC As Long ' 条件に合致したセル数(Number of Cell)
Dim Nod2 As Long ' Nod1の逆
'【コード】
sheet1.Activate ' 対象シートをアクティブ化
Day1 = Date ' 今日
Day1 = DateAdd("d", Nod1, Day1) ' -Nod1日前
For Each Range1 In myRange1
If (Range1.Value <> "") And (Range1.Value < Day1) Then ' 変更日が-Nod1日より前
If Range_t Is Nothing Then
Set Range_t = Range1 ' 最初に条件に合致したセル
Set Range2 = Range1 ' 最初に条件に合致したセル(最も古い日付)
Day2 = Range1.Value ' 最も古い日付を更新
NoC = 1 ' 合致したセル数をカウント
Else
Set Range_t = Union(Range_t, Range1) ' 2個目以降に条件に合致したセルを結合
NoC = NoC + 1 ' 合致したセル数をカウントアップ
If Range1.Value < Day2 Then
Set Range2 = Range1 ' 最も古い日付のセルを更新
Day2 = Range1.Value ' 最も古い日付を更新
End If
End If
End If
Next Range1
If Not (Range_t Is Nothing) Then ' 合致したセルがあったら
' Application.Goto Range2, True ' パスワード変更から-Nod1日経過したセルの内、最古のセルへ
Range_t.Select ' パスワード変更から-Nod1日経過したセル範囲を選択
Range2.Activate ' パスワード変更から-Nod1日経過したセルの内、最古のセルをActivate
ActiveWindow.SmallScroll ToLeft:=Range_t(1, 1).Column - 1 ' A列が一番左になるようにスクロール
Nod2 = 0 - Nod1 ' Nod1の符号を反転
MsgBox ("変更から" & Nod2 & "日以上経過したパスワードは" & NoC & "個あります。" & _
vbCrLf & "最古は" & Range2.Address & "(" & Day2 & ")です。") ' 合致したセル数の表示
End If
End Sub
【解説】
・For Each文で、myRange1 のセル範囲内のセルの値を調べていきます。
・セル範囲に"変更日"という名前を付けているのは、セル範囲が変更になってもマクロ変更しなくてもすむようにです。
・アクティブシートを退避して、"current"シートをアクティブ化していますが、マクロ実行前のアクティブシートに戻っていないので、退避する必要はない、ですね。。
・変更日のセルが空白の場合は対象としないよう、(Range1.Value <> "") ではじいています。
・Nod1はマイナスの値で与えられることに注意してください。
・条件に合致したセルをRange_tに格納しますが、1セル目と2セル目では格納の仕方が異なります。1セル目かどうか、つまり、Range_tが空っぽかどうかを、Nothingを使って判定しています。
ヤバイぜ! ありがとうございます[__猫]
HenKigen1マクロのActiveWindow.SmallScroll ToLeft:=6の実行順番を Range2.Activateの後ろに移動しました。
by cheese999 (2016-07-15 20:43)
HenKigen1マクロの
ActiveWindow.SmallScroll ToLeft:=6
を
ActiveWindow.SmallScroll ToLeft:=Range_t(1, 1).Column - 1
に変え、G列でなくても、マクロが動けるようにしました。
by cheese999 (2016-07-16 00:15)
こんばんは。
NICE&コメントありがとうございました。
又お邪魔しますね。
by cyoko1112 (2016-07-16 21:11)
cyoko1112さん、
どういたしまして。
(^_0)ノ
by cheese999 (2016-07-16 23:42)