エクセル小僧:今日のデータを入力するセルへ(3) [コンピューター]
今日のデータを入力するセルへ(2)
http://cheese999.blog.so-net.ne.jp/2014-09-26
を、少し変更してみました。
前回の記事では、今日の日付を見つけたら、Application.Goto命令で今日の日付のセルへジャンプし、SmallScroll命令で表示位置を調整するというものでした。
このマクロを実装した表を使ってもらった方から、次の意見をもらいました。
「左から右へ一行目に日付が並んでいる表で、このマクロを動作させたとき、カーソル位置の列番号は今日の日付に合わせて欲しいけど、カーソル位置の行番号は変えないで欲しい。」
例えば、カーソルがD11セル、今日の日付がN1セルある状態でマクロを動作させたら、カーソルがN11セルへジャンプして欲しいということです。
N1セル(今日の日付)を見つけたら、N11セル(新しいカーソル位置)を選択し、N列(今日の列)から、D列(元のカーソル位置の列)の列数の差(=14-4=10)の分、右へスクロールするようにマクロを書き換えました。
01: Sub JumpToday()
02: ' 機能:今日の日付へ飛ぶ
03: ' 【変数】
04: Dim r1 As Range ' 繰り返し用
05: Dim yy1(2) As Integer ' 年
06: Dim mm1(2) As Integer ' 月
07: Dim dd1(2) As Integer ' 日
08: Dim Flag1 As Integer ' フラグ
09: Dim Row1 As Long ' 行番号
10: Dim Column1 As Long ' 列番号
11: ' 【実行コード】
12: ' Application.ScreenUpdating = False ' 画面更新停止
13: yy1(0) = Year(Date) ' 今日の年
14: mm1(0) = Month(Date) ' 今日の月
15: dd1(0) = Day(Date) ' 今日の日
16: Row1 = ActiveCell.Row ' カーソル位置の行番号
17: Column1 = ActiveCell.Column ' カーソル位置の列番号
18: ' 今日の日付を探す
19: Flag1 = 0
20: Call FindToday1(Range("月日"), r1, Flag1, yy1, mm1, dd1)
21: ' 今日の日付無し
22: If (Flag1 = 0) Then
23: MsgBox "今日(" & Date & ")の日付が見つかりません。"
24: Else
25: ' 今日の日付の列、元のカーソル位置の行のセルを選択
26: Set r1 = Cells(Row1, r1.Column)
27: r1.Select
28: ' 今日の日付の列まで右にスクロール
29: ActiveWindow.SmallScroll ToRight = (r1.Column - Column1)
30: End If
31: ' Application.ScreenUpdating = True ' 画面更新再開
32: End Sub
01: Sub FindToday1(ByRef myRange1 As Range, ByRef r1 As Range, _
02: ByRef Flag1 As Integer, ByRef yy1() As Integer, ByRef mm1() As Integer, _
03: ByRef dd1() As Integer)
04: ' 機能:myRange1の範囲から今日の日付を探し、見つかったら、r1にセル位置を代入
05: ' 【変数】
06: ' myRange1 : 今日の日付を探す範囲
07: ' r1 : 今日の日付のセル範囲
08: ' Flag1 : 0/1 = 見つからない/見つかった
09: ' yy1(0) : 今日の年
10: ' mm1(0) : 今日の月
11: ' dd1(0) : 今日の日
12: ' yy1(1) : 探すセル範囲のセルの年
13: ' mm1(1) : 探すセル範囲のセルの月
14: ' dd1(1) : 探すセル範囲のセルの日
15: For Each r1 In myRange1
16: yy1(1) = Year(r1.Value) ' 年
17: mm1(1) = Month(r1.Value) ' 月
18: dd1(1) = Day(r1.Value) ' 日
19: If (yy1(0) = yy1(1)) And (mm1(0) = mm1(1)) And (dd1(0) = dd1(1)) Then
20: Flag1 = 1
21: Exit For
22: End If
23: Next r1
24: End Sub
なお、今日の日付を探すセル範囲「月日」は、「$F$1:$AM$1」に設定しています。
1行目、2行目のセルは下記の様になっています。
表示形式は1行目が「m/d;@」、2行目が「(aaa)」です。
http://cheese999.blog.so-net.ne.jp/2014-09-26
を、少し変更してみました。
前回の記事では、今日の日付を見つけたら、Application.Goto命令で今日の日付のセルへジャンプし、SmallScroll命令で表示位置を調整するというものでした。
このマクロを実装した表を使ってもらった方から、次の意見をもらいました。
「左から右へ一行目に日付が並んでいる表で、このマクロを動作させたとき、カーソル位置の列番号は今日の日付に合わせて欲しいけど、カーソル位置の行番号は変えないで欲しい。」
例えば、カーソルがD11セル、今日の日付がN1セルある状態でマクロを動作させたら、カーソルがN11セルへジャンプして欲しいということです。
N1セル(今日の日付)を見つけたら、N11セル(新しいカーソル位置)を選択し、N列(今日の列)から、D列(元のカーソル位置の列)の列数の差(=14-4=10)の分、右へスクロールするようにマクロを書き換えました。
01: Sub JumpToday()
02: ' 機能:今日の日付へ飛ぶ
03: ' 【変数】
04: Dim r1 As Range ' 繰り返し用
05: Dim yy1(2) As Integer ' 年
06: Dim mm1(2) As Integer ' 月
07: Dim dd1(2) As Integer ' 日
08: Dim Flag1 As Integer ' フラグ
09: Dim Row1 As Long ' 行番号
10: Dim Column1 As Long ' 列番号
11: ' 【実行コード】
12: ' Application.ScreenUpdating = False ' 画面更新停止
13: yy1(0) = Year(Date) ' 今日の年
14: mm1(0) = Month(Date) ' 今日の月
15: dd1(0) = Day(Date) ' 今日の日
16: Row1 = ActiveCell.Row ' カーソル位置の行番号
17: Column1 = ActiveCell.Column ' カーソル位置の列番号
18: ' 今日の日付を探す
19: Flag1 = 0
20: Call FindToday1(Range("月日"), r1, Flag1, yy1, mm1, dd1)
21: ' 今日の日付無し
22: If (Flag1 = 0) Then
23: MsgBox "今日(" & Date & ")の日付が見つかりません。"
24: Else
25: ' 今日の日付の列、元のカーソル位置の行のセルを選択
26: Set r1 = Cells(Row1, r1.Column)
27: r1.Select
28: ' 今日の日付の列まで右にスクロール
29: ActiveWindow.SmallScroll ToRight = (r1.Column - Column1)
30: End If
31: ' Application.ScreenUpdating = True ' 画面更新再開
32: End Sub
01: Sub FindToday1(ByRef myRange1 As Range, ByRef r1 As Range, _
02: ByRef Flag1 As Integer, ByRef yy1() As Integer, ByRef mm1() As Integer, _
03: ByRef dd1() As Integer)
04: ' 機能:myRange1の範囲から今日の日付を探し、見つかったら、r1にセル位置を代入
05: ' 【変数】
06: ' myRange1 : 今日の日付を探す範囲
07: ' r1 : 今日の日付のセル範囲
08: ' Flag1 : 0/1 = 見つからない/見つかった
09: ' yy1(0) : 今日の年
10: ' mm1(0) : 今日の月
11: ' dd1(0) : 今日の日
12: ' yy1(1) : 探すセル範囲のセルの年
13: ' mm1(1) : 探すセル範囲のセルの月
14: ' dd1(1) : 探すセル範囲のセルの日
15: For Each r1 In myRange1
16: yy1(1) = Year(r1.Value) ' 年
17: mm1(1) = Month(r1.Value) ' 月
18: dd1(1) = Day(r1.Value) ' 日
19: If (yy1(0) = yy1(1)) And (mm1(0) = mm1(1)) And (dd1(0) = dd1(1)) Then
20: Flag1 = 1
21: Exit For
22: End If
23: Next r1
24: End Sub
なお、今日の日付を探すセル範囲「月日」は、「$F$1:$AM$1」に設定しています。
1行目、2行目のセルは下記の様になっています。
行番号 | F列 | G列 | - | AM列 |
1 | 2014/11/1 | =DATE(YEAR(F1),MONTH(F1),DAY(F1)+1) | - | =DATE(YEAR(AL1),MONTH(AL1),DAY(AL1)+1) |
2 | =F1 | =G1 | - | =AM1 |
表示形式は1行目が「m/d;@」、2行目が「(aaa)」です。
見てると眠くなります。。(^_^)
by なんだかなぁ〜!! 横 濱男 (2014-11-09 22:51)
なんだかなぁ〜!! 横 濱男さん、
おやすみなさい。。(^_0)ノ
by cheese999 (2014-11-12 01:57)
「ヤバイぜ!」 ありがとうございます。[__猫]
by cheese999 (2014-11-12 01:58)