看護師です。体温表のマクロを短縮化させたいです。

以下のマクロをより短く出来ませんか？よろしくお願いしますｍ－－ｍ

Case "M50"
Range("O50").Select
Case "O50"
Range("Q50").Select
Case "Q50"
Range("R50").Select
Case "R50"
Range("M51").Select
Case "M51"
Range("O51").Select
Case "O51"
Range("Q51").Select
Case "Q51"
Range("R51").Select
Case "R51"
Range("M52").Select
Case "M52"
Range("O52").Select
Case "O52"
Range("Q52").Select
Case "Q52"
Range("R52").Select
Case "R52"
Range("M53").Select
Case "M53"
Range("O53").Select
Case "O53"
Range("Q53").Select
Case "Q53"
Range("R53").Select

No.5 回答者： moto_koukousei 回答日時： 2016/01/28 07:25

N0.4の回答で一部誤りをしていました。

前の回答では、1月のシートのとき、G50のセルでエラーを起こします。
次のように、修正します。

《ThisWorkbookのモジュール：前の回答と同じ内容》
Private Sub Workbook_Open()
Application.ScreenUpdating = False
Range("D50").Select
skip
TB_S
TB_T
Application.ScreenUpdating = True
End Sub

《どこかの標準モジュール：例えば　Module2》
Public TbS(1 To 7, 1 To 2) As Integer
Public TbT(1 To 6, 1 To 2) As Integer


Sub skip()
Application.OnKey "~", "macro_new"
Application.OnKey "{enter}", "macro_new"
End Sub

Sub TB_S()
TbS(1, 1) = 0: TbS(1, 2) = 2
TbS(2, 1) = 1: TbS(2, 2) = 0
TbS(3, 1) = 0: TbS(3, 2) = 1
TbS(4, 1) = -1: TbS(4, 2) = 2
TbS(5, 1) = 1: TbS(5, 2) = 0
TbS(6, 1) = 0: TbS(6, 2) = 1
TbS(7, 1) = 1: TbS(7, 2) = 0
End Sub

Sub TB_T()
TbT(1, 1) = 0: TbT(1, 2) = 2
TbT(2, 1) = 1: TbT(2, 2) = 0
TbT(3, 1) = 0: TbT(3, 2) = 2
TbT(4, 1) = 1: TbT(4, 2) = 0
TbT(5, 1) = 0: TbT(5, 2) = 1
TbT(6, 1) = 1: TbT(6, 2) = -5
End Sub


Sub macro_new()
mr = ActiveCell.Row: mc = ActiveCell.Column
ma = ActiveCell.Address(0, 0)

If ma = "C28" Then Range("J50").Select: Exit Sub

If ma = "G50" Then
hhf = Replace(ActiveSheet.Name, "月", "")
hhg = (Val(hhf) - 1)
If hhg = 0 Then Range("C28").Select: Exit Sub
' 　この上の一行が抜けていたので、修正追加した
Worksheets(hhg & "月").Activate
hhh = Range("h47") & "/" & hhg & "/1"
hhi = Day(WorksheetFunction.EoMonth(DateValue(hhh), 0)) + 49
Cells(hhi, 10).Select: Exit Sub
End If

If ma = "I80" Then Range("J81").Select: Exit Sub

If mr > 49 And mr < 81 And mc > 3 And mc < 11 Then
mcs = mc - 3
ActiveCell.Offset(TbS(mcs, 1), TbS(mcs, 2)).Select
Exit Sub
gfh = jjhg
End If

If mr > 49 And mr < 110 And mc > 12 And mc < 43 Then
ccl = Int((mc - 12) / 8) * 8 + 12: ccr = ccl + 7
rru = Int((mr - 49) / 8) * 8 + 49: rrd = rru + 5
be = Cells(rrd - 1, ccr - 1).Address(0, 0)
If mr > 105 And mc > 36 Then
ActiveCell.Offset(1, 0).Select: Exit Sub
End If
If mr < rrd And mr > rru And mc > ccl And mc < ccr Then
If ma = be Then Exit Sub
mcs = mc - ccl
ActiveCell.Offset(TbT(mcs, 1), TbT(mcs, 2)).Select
Exit Sub
End If
ActiveCell.Offset(1, 0).Select
Exit Sub
End If
ActiveCell.Offset(1, 0).Select
End Sub

No.4 回答者： moto_koukousei 回答日時： 2016/01/27 23:32

既に締め切られた質問がありました。

https://oshiete.goo.ne.jp/qa/9159277.html
その質問のなかで、とても長いコードが書かれていました。
http://4vote.sakura.ne.jp/macro.html
上にあるコードの一部のようです。
元のコードならば、次のようにしても、ほぼ、同じ動きをします。

《ThisBookに》

Private Sub Workbook_Open()
Application.ScreenUpdating = False
Range("D50").Select
skip
TB_S
TB_T
Application.ScreenUpdating = True
End Sub


《適当なモジュールに》

Public TbS(1 To 7, 1 To 2) As Integer
Public TbT(1 To 6, 1 To 2) As Integer
～～～～～～～～～～～～～～～～～～～

Sub skip()
Application.OnKey "~", "macro_new"
Application.OnKey "{enter}", "macro_new"
End Sub
～～～～～～～～～～～～～～～～～～～

Sub TB_S()
TbS(1, 1) = 0: TbS(1, 2) = 2
TbS(2, 1) = 1: TbS(2, 2) = 0
TbS(3, 1) = 0: TbS(3, 2) = 1
TbS(4, 1) = -1: TbS(4, 2) = 2
TbS(5, 1) = 1: TbS(5, 2) = 0
TbS(6, 1) = 0: TbS(6, 2) = 1
TbS(7, 1) = 1: TbS(7, 2) = 0
End Sub
～～～～～～～～～～～～～～～～～～

Sub TB_T()
TbT(1, 1) = 0: TbT(1, 2) = 2
TbT(2, 1) = 1: TbT(2, 2) = 0
TbT(3, 1) = 0: TbT(3, 2) = 2
TbT(4, 1) = 1: TbT(4, 2) = 0
TbT(5, 1) = 0: TbT(5, 2) = 1
TbT(6, 1) = 1: TbT(6, 2) = -5
End Sub
～～～～～～～～～～～～～～～～～～

Sub macro_new()
mr = ActiveCell.Row: mc = ActiveCell.Column
ma = ActiveCell.Address(0, 0)

If ma = "C28" Then Range("J50").Select: Exit Sub

If ma = "G50" Then
hhf = Replace(ActiveSheet.Name, "月", "")
hhg = (Val(hhf) - 1)
Worksheets(hhg & "月").Activate
hhh = Range("h47") & "/" & hhg & "/1"
hhi = Day(WorksheetFunction.EoMonth(DateValue(hhh), 0)) + 49
Cells(hhi, 10).Select: Exit Sub
End If

If ma = "I80" Then Range("J81").Select: Exit Sub

If mr > 49 And mr < 81 And mc > 3 And mc < 11 Then
mcs = mc - 3
ActiveCell.Offset(TbS(mcs, 1), TbS(mcs, 2)).Select
Exit Sub
gfh = jjhg
End If

If mr > 49 And mr < 110 And mc > 12 And mc < 43 Then
ccl = Int((mc - 12) / 8) * 8 + 12: ccr = ccl + 7
rru = Int((mr - 49) / 8) * 8 + 49: rrd = rru + 5
be = Cells(rrd - 1, ccr - 1).Address(0, 0)
If mr > 105 And mc > 36 Then
ActiveCell.Offset(1, 0).Select: Exit Sub
End If
If mr < rrd And mr > rru And mc > ccl And mc < ccr Then
If ma = be Then Exit Sub
mcs = mc - ccl
ActiveCell.Offset(TbT(mcs, 1), TbT(mcs, 2)).Select
Exit Sub
End If
ActiveCell.Offset(1, 0).Select
Exit Sub
End If
ActiveCell.Offset(1, 0).Select
End Sub

No.3 回答者： Hypnomatic 回答日時： 2016/01/25 20:15

同じような質問連投して、自分でコード改善する術も知らないような奴に教えるだけ無駄

あんたのために時間割いてコード書いてくれる人に礼もできない訳？看護師辞めたら？

No.2 回答者： hallo-2007 回答日時： 2016/01/25 19:39

前後がわかりませんが、シートモジュールのChangeイベントの

一部でしょうか？
If Taregt.Row>=50 Then
If Target.Column=13 Or Target.Column=15 Then
Tareget.Offset(0,2).Select
Endif

If Target.Column=17 Then
Tareget.Offset(0,1).Select
Endif


If Target.Column=18 Then
Tareget.Offset(1,-5).Select
Endif
Endif
こんな感じで考えてみてはいかがでしょうか。

No.1 回答者： nokirag 回答日時： 2016/01/25 02:31

全体のコードを見ないとなんとも評価できないのですが、

不思議な変換法則なので、テーブルを使うパターンで多少見やすくなるかと思います。

------------------------------------------------------------
パターンA　変換テーブルを使う
Dim XXXX As String = "M50" 'Selectで使ってる比較用の値

Dim Table As Object
Set Table = CreateObject("Scripting.Dictionary")

Table.Add "M50", "O50"
Table.Add "O50", "Q50"
Table.Add "Q50", "R50"
Table.Add "R50", "M51"
Table.Add "M51", "O51"
Table.Add "O51", "Q51"
Table.Add "Q51", "R51"
Table.Add "R51", "M52"
Table.Add "M52", "O52"
Table.Add "O52", "Q52"
Table.Add "Q52", "R52"
Table.Add "R52", "M53"
Table.Add "M53", "O53"
Table.Add "O53", "Q53"
Table.Add "Q53", "R53"

If Table.Exists(XXXX) Then
Range(Table.Item(XXXX)).Select
Else
'ない場合はどういう処理をするのでしょうか？
End If
------------------------------------------------------------




↓多少トリッキーになりますが、このようになるかもしれません。列番号が以下3つのみの場合と考えていい場合ですが。
※RowとColumn、行と列があやふやなので説明や変数名が間違えている場合は意訳して解釈してくださいｗ
M => O
O => Q
R => M
------------------------------------------------------------
パターンB

Dim XXXX As String = "M50" 'Selectで使ってる比較用の値
Dim XXXX_Row As String
Dim XXXX_Column As String
Set Table = CreateObject("Scripting.Dictionary")
Table.Add "M", "O"
Table.Add "O", "Q"
Table.Add "Q", "R"

XXXX_Row = Left(XXXX,1) ' 列番号が1桁のみ、2桁以上の場合はバグとなります。もしそのようなケースがあれば、多少帰る必要があります
XXXX_Column = Right(XXXX,2) ' 行番号が2桁のみ、3桁以上の場合はバグとなります。 〃

If Table.Exists(XXXX_Row) Then
Range(Table.Item(XXXX_Row) & XXXX_Column).Select
Else
'ない場合はどういう処理をするのでしょうか？
End If
------------------------------------------------------------


上記コードは実行して試したりなどしてないので、もし採用される場合は、十分検証してください