Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


17357 / 76732 ←次へ | 前へ→

【64831】Re:オートシェイプのマクロについて
発言  ichinose  - 10/3/17(水) 7:56 -

引用なし
パスワード
   ▼椿 さん:
おはようございます。

>例:A1セルに"刹那X5"を打てば、オートシェイプに入り(ここまではマクロ不要です)、オートシェイプ内に刹那X5と表記され、X5がキーワードとしてオートシェイプの色を変更するマクロを作りたいのですが、うまくいきませんのでよろしくお願いいたします。
うまくいかないコードを提示するようにしてくださいね!!

新規ブックにて

標準モジュールに

'===========================================================
Sub 準備()
  Dim rng As Range
  With ActiveSheet
    Set rng = .Range("c5:e6")
    With .TextBoxes.Add(rng.Left, rng.Top, rng.Width, rng.Height)
     .Name = "T1"
     .Formula = "=$a$1"
     With .Font
       .Size = 16
     End With
     .HorizontalAlignment = xlCenter
     .VerticalAlignment = xlCenter
    End With
  End With
End Sub

Sheet1をアクティブにして、上記の「準備」を実行してください。
テキストボックスですが、C5:E6辺りに作成されます。

次に Sheet1のシートモジュールに

'=============================================================
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
  Dim regx As Object
  Dim matches As Object
  Dim ttarget As Range
  Dim 色替えリスト As Variant
  Dim 色 As Variant
  Dim idx As Variant
  色替えリスト = Array("x5", "y11", "zz33", "D51")
  色 = Array(vbRed, vbCyan, vbYellow, vbBlue)
  Set ttarget = Application.Intersect(Target, Range("a1"))
  If Not ttarget Is Nothing Then
    TextBoxes("T1").Interior.ColorIndex = xlNone
    Set regx = CreateObject("VBScript.RegExp")
    regx.Pattern = "(" & Join(色替えリスト, "|") & ")$"
    regx.IgnoreCase = True
    regx.Global = True
    Set matches = regx.Execute(ttarget.Value)
    If matches.Count = 1 Then
     idx = Application.Match(matches(0).Value, 色替えリスト, 0)
     TextBoxes("T1").Interior.Color = 色(idx - 1)
    End If
    Set regx = Nothing
    Set matches = Nothing
  End If
  Set ttarget = Nothing
End Sub


Sheet1のセルA1に 刹那x5 と指定するとテキストボックスが赤くなります。

色の変化のある文字列は、

末尾が x5  y11   zz33  D51 に対して
    赤 シアン  黄   青  に設定してあります。

それ以外は、色なし


これで試してみてください。
0 hits

【64830】オートシェイプのマクロについて 椿 10/3/17(水) 0:39 質問
【64831】Re:オートシェイプのマクロについて ichinose 10/3/17(水) 7:56 発言
【64833】Re:オートシェイプのマクロについて 椿 10/3/17(水) 16:44 お礼

17357 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free