マクロの追加をお願いしたいですm(_ _)m

質問

以前こちらで教えていただきましたマクロを使用していまして、要改善点が２つほど見つかりましたので、どなたかご教授いただけないでしょうか？

現在使用しているマクロと改善希望点を以下に記載しますので、宜しくお願いします。

１．カナが含まれるセルに対して反応させたいです。

２．コマンドボタンを使用して、特定のセルに対して、反応させることは出来ますでしょうか？

以下、現使用マクロです。

Private Sub Worksheet_Change(ByVal Target As Range)

Application.EnableEvents = False
With Target
セルの内容 = Replace(.Value, "　", "", 1, -1, vbTextCompare)
'すべて全角文字で　数字を含まない場合　名前　とみなす
If Not セルの内容 Like "*#*" And 0 < Len(セルの内容) And _
セルの内容 = StrConv(セルの内容, vbUpperCase Or vbNarrow) And _
セルの内容 = StrConv(セルの内容, vbLowerCase Or vbWide) Then

'実際に私が行いたいこと・・「 "さま"を付けて」
敬称 = "さま"

.Value = .Value & 敬称

If 30 < .Font.Size Then
'セルのフォントサイズより２０下のサイズ
.Characters(Start:=Len(.Value) - Len(敬称) + 1, _
Length:=Len(敬称)).Font.Size = .Font.Size - 20
Else
'セルのフォントサイズの70%
.Characters(Start:=Len(.Value) - Len(敬称) + 1, _
Length:=Len(敬称)).Font.Size = Int(.Font.Size * 0.7) + 1
End If

End If
End With
Application.EnableEvents = True
End Sub

以上、宜しくお願い致します。

回答No.2

Wendy02 · ベストアンサー

こんばんは。
Wendy02 です。

＞別のシートに転記（ex.sheet1!A2)させた時に、２種類のフォントサイズが１種類に戻ってしまうのです。

転記というのは、
=Sheet1!A2
とさせることですね。

そこで、二つの解決法があります。
私個人としては、最初のほうが好みです。

ひとつは、図のリンク貼り付けで、もう一つは、マクロです。

・図のリンク貼り付けは、

その文字列の範囲（A2であっても、列がまたがっているのでしたら、その範囲を含ませます。(例　A2:C2）を選択して、コピーします。

貼り付ける場所にセルポインターを置き、シフトキーを押しながら、編集で、
　図のリンク貼り付け
をクリックします。

式は、=Sheet1!$A$2:$C$2 となって、画像として、そのまま写されているはずです。
印刷をしてみましたが、まったく違いはありませんでした。

・マクロの場合
こちらは、書式をコピーすれば、一つになってしまいますので、転記先からコピーしなければなりません。そして式が消えて定数になってしまいます。

この方法は、単に式を読んで、その式の先にある文字列をコピーしてくるというものです。
前と同じようにボタンにしたらよいかと思います。

Option Explicit
Sub TestSample2()
　 Dim myFormula As String, myWSh As Worksheet, strRng As String
　 Dim num As Integer, myRng As Range
　 With ActiveCell
　　　If Not (IsNumeric(.Text)) And .HasFormula Then
　　　　 num = InStr(.FormulaLocal, "!")
　　　　 If num > 0 Then
　　　　　　myFormula = Mid$(.FormulaLocal, 2)
　　　　　　On Error GoTo ErrHandler
　　　　　　Set myWSh = Worksheets(Mid$(myFormula, 1, num - 2))
　　　　　　strRng = Mid$(myFormula, num)
　　　　　　myWSh.Range(strRng).Copy
　　　　　　.PasteSpecial
　　　　　　Application.CutCopyMode = True
　　　　 End If
　　　　 Else
　　　　 MsgBox "コピーできません。式とコピー先を確認してください。", 16
　　　End If
　 End With
　 Exit Sub
ErrHandler:
　 MsgBox "その式は、コピーは出来ません。", 16
End Sub

お礼

ご回答ありがとうございました。

図のリンク貼り付けで私の希望どおりの結果が出ました。
リンク貼り付けって基本的なことだとは思いますが、調べることが出来ず、思いつくことも出来ず。。。

本当に今回は前回含めて感謝しております。

２つ目の方法であるマクロに関しては、のちのち試してみたいと思います。

いやぁ、本当にすっきりしました。３ヶ月くらい悩んでましたので・・・

多謝。

回答No.1

Wendy02

こんばんは。Wendy02 です。

http://oshiete1.goo.ne.jp/kotaeru.php3?q=1335605

前回、十分にサポートできずにすみません。

もしかしたら、今回書かれているようなイベント型をお望みではないのではありませんか？その「さま」の付けるタイミングをどのように取るのか、未だに分りません。

ボタンを押した時点でしょうか？

＞１．カナが含まれるセルに対して反応させたいです。

そのスレッドにいた私としては、そのご質問のマクロの訂正は可能ですが、それは遠慮いたします。

それはともかく、私自身の元のコードを修正しました。

＞２．コマンドボタンを使用して、特定のセルに対して、反応させることは出来ますでしょうか？

コントロールツールからコマンドボタンをシートに貼り付けて、ボタンをセレクトしたまま、右クリック－コードの表示で、Visual Basci Editor が出てきますから、
Sub CommandButton1_Click()の下に下記のコードの中身を入れてください。

これは、複数の範囲でも、選択して、ボタンを押せば変換が可能です。

Private Sub CommandButton1_Click()
　Dim Rng As Range
　 Dim c As Range
　 Application.ScreenUpdating = False
　'変換範囲を、A1:A20 にする
　 If Intersect(Selection, Range("A1:A20")) Is Nothing Then Exit Sub
　 Set Rng = Selection
　 For Each c In Rng
　　　With c
　　　　 If Not (.HasFormula _
　　　　　　Or LenB(StrConv(.Value, vbFromUnicode)) <> LenB(.Value)) Then
　　　　　　If Right(.Value, 2) <> "さま" Then
　　　　　　　 .Value = .Value & "さま" 'さまがなければ「さま」をつける
　　　　　　End If
　　　　　　If .Font.Size > 30 Then
　　　　　　　　　.Characters(Start:=Len(.Value) - 1, Length:=2).Font.Size = _
　　　　　　　　　.Font.Size - 20 'セルのフォントサイズより20下のサイズ
　　　　　　End If
　　　　 End If
　　　End With
　 Next c
　 Application.ScreenUpdating = True
　 Set Rng = Nothing
End Sub

お礼

上記コードを試用してみました。結果、思っていた通りのことが出来たのですが、１点だけ不都合が生じてしまいました。それは、別のシートに転記（ex.sheet1!A2)させた時に、２種類のフォントサイズが１種類に戻ってしまうのです。つまり、転記させたセルには氏名と「さま」が同一フォントサイズになってしまったのです。これに関しては、どうにかならないでしょうか？あと一歩のところで、非常に困っております。