以下のマクロをより短く出来ませんか?よろしくお願いしますm--m
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
A 回答 (5件)
- 最新から表示
- 回答順に表示
No.5
- 回答日時:
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
- 回答日時:
既に締め切られた質問がありました。
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
- 回答日時:
同じような質問連投して、自分でコード改善する術も知らないような奴に教えるだけ無駄
あんたのために時間割いてコード書いてくれる人に礼もできない訳?看護師辞めたら?
No.2
- 回答日時:
前後がわかりませんが、シートモジュールの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
- 回答日時:
全体のコードを見ないとなんとも評価できないのですが、
不思議な変換法則なので、テーブルを使うパターンで多少見やすくなるかと思います。
------------------------------------------------------------
パターン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、行と列があやふやなので説明や変数名が間違えている場合は意訳して解釈してくださいw
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
------------------------------------------------------------
上記コードは実行して試したりなどしてないので、もし採用される場合は、十分検証してください
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) マクロを短くする 1 2023/01/15 00:11
- Visual Basic(VBA) マクロで最終行を取得してコピーしたい 3 2022/04/06 19:07
- Visual Basic(VBA) データのある範囲を選択するVBAについて 2 2022/09/03 00:20
- Excel(エクセル) 表示形式、文字列セル(列)に数式を入力するには マクロ 1 2022/09/18 10:53
- Excel(エクセル) ②Excel 簡単にシートコピーしたら前日の残高と日付を変更させたい→マクロの記録でエラーが出ます 8 2022/07/16 20:40
- Visual Basic(VBA) Excelのマクロ ブック間である範囲をコピー Workbooks(“a.xlsx“).Sheets 3 2022/05/12 17:02
- Visual Basic(VBA) エクセルのマクロについて教えてください。 4 2023/07/04 17:58
- Visual Basic(VBA) エクセルのマクロを使ってメールを送る方法について教えてください 2 2022/03/29 01:36
- Visual Basic(VBA) ExcelのVBAコードについて教えてください。 4 2023/05/26 10:43
- Visual Basic(VBA) excel2021で実行できないマクロ。どこを直したらいいのか 2 2022/03/28 03:40
関連するカテゴリからQ&Aを探す
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
縦横比率のを変えずに画像のサ...
-
テキストファイルから読み込ん...
-
四角形の端っこをドラッグした...
-
ラッコって?
-
看護師です。体温表のマクロを...
-
VBAで改行の入ったデータの正規...
-
VBScriptでMsgBoxのYesNoボック...
-
【VB.NET】別Formのボタンが押...
-
C# chart controlの透過について
-
static関数がmapファイルに載ら...
-
プログラミング、アーキテクチ...
-
ACCESSフォームで、入力から一...
-
Actionscriptでふわふわ感を再...
-
画面の範囲選択
-
アセンブリ言語のcasl2について...
-
'2465'指定した式で参照してい...
-
POIでのテキストボックス作成に...
-
C言語でのマウスを移動とマウス...
-
python ボタンを押すと複数の関...
-
photoshopで書いた四角の枠の中...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
VBAで改行の入ったデータの正規...
-
VBAユーザーホームテキストボッ...
-
テキストファイルから読み込ん...
-
Flashで外部jpgファイルをmcに...
-
FlashでドラッグしたMCをリセッ...
-
AS3 mc0~5をまとめて処理する
-
upc 7915と mc7915ctは互換性有...
-
ラッコって?
-
縦横比率のを変えずに画像のサ...
-
テキスト入力
-
ステージの背景画像のみ拡大縮...
-
eval関数を利用して複数の処理...
-
ランダムに mcを連続attachM...
-
外部SWFファイルを再生バーでコ...
-
四角形の端っこをドラッグした...
-
看護師です。体温表のマクロを...
-
as3 addchildで生成したMCにリ...
-
Flashからリンクする際のconfir...
-
以下のActionScriptをスッキリ...
-
Suzukaで一行ニュースティッカ...
おすすめ情報